# library imports
library(tidyverse)
library(scales)
library(limma)
library(edgeR)
library(psych)

# ============== CV function ===================================================
CV <- function(df) {
    # Computes CVs of data frame rows
        # df - data frame,
        # returns vector of CVs (%)
    ave <- rowMeans(df)    # compute averages
    sd <- apply(df, 1, sd) # compute standard deviations
    cv <- 100 * sd / ave   # compute CVs in percent (last thing gets returned)
}

# =========== Boxplot with median label ========================================
labeled_boxplot <- function(df, ylim, title) {
    # Makes a box plot with the median value labeled
        # df - data frame with data to compute CVs of
        # ylim - upper limit for y-axis
        # title - plot title
    cv = CV(df)
    boxplot(cv, ylim = c(0, ylim), notch = TRUE, main = title)
    text(x = 0.65, y = boxplot.stats(cv)$stats[3],
         labels = round(boxplot.stats(cv)$stats[3], 1))
}

# ================== TMM normalization from DGEList object =====================
apply_tmm_factors <- function(y, color = NULL, plot = TRUE) {
    # computes the tmm normalized data from the DGEList object
        # y - DGEList object
        # returns a dataframe with normalized intensities

    # compute and print "Sample loading" normalization factors
    lib_facs <- mean(y$samples$lib.size) / y$samples$lib.size
    cat("\nLibrary size factors:\n",
        sprintf("%-5s -> %f\n", colnames(y$counts), lib_facs))

    # compute and print TMM normalization factors
    tmm_facs <- 1/y$samples$norm.factors
    cat("\nTrimmed mean of M-values (TMM) factors:\n",
        sprintf("%-5s -> %f\n", colnames(y$counts), tmm_facs))

    # compute and print the final correction factors
    norm_facs <- lib_facs * tmm_facs
    cat("\nCombined (lib size and TMM) normalization factors:\n",
        sprintf("%-5s -> %f\n", colnames(y$counts), norm_facs))

    # compute the normalized data as a new data frame
    tmt_tmm <- as.data.frame(sweep(y$counts, 2, norm_facs, FUN = "*"))
    colnames(tmt_tmm) <- str_c(colnames(y$counts), "_tmm")

    # visualize results and return data frame
    if(plot == TRUE) {
        boxplot(log10(tmt_tmm), col = color, notch = TRUE, main = "TMM Normalized data")
    }
    tmt_tmm
}

# ================= reformat edgeR test results ================================
collect_results <- function(df, tt, x, xlab, y, ylab) {
    # Computes new columns and extracts some columns to make results frame
        # df - data in data.frame
        # tt - top tags table from edgeR test
        # x - columns for first condition
        # xlab - label for x
        # y - columns for second condition
        # ylab - label for y
        # returns a new dataframe

    # condition average vectors
    ave_x <- rowMeans(df[x])
    ave_y <- rowMeans(df[y])

    # FC, direction, candidates
    fc <- ifelse(ave_y > ave_x, (ave_y / ave_x), (-1 * ave_x / ave_y))
    direction <- ifelse(ave_y > ave_x, "up", "down")
    candidate <- cut(tt$FDR, breaks = c(-Inf, 0.01, 0.05, 0.10, 1.0),
                     labels = c("high", "med", "low", "no"))

    # make data frame
    temp <- cbind(df[c(x, y)], data.frame(logFC = tt$logFC, FC = fc,
                                          PValue = tt$PValue, FDR = tt$FDR,
                                          ave_x = ave_x, ave_y = ave_y,
                                          direction = direction, candidate = candidate,
                                          Acc = tt$genes))

    # fix column headers for averages
    names(temp)[names(temp) %in% c("ave_x", "ave_y")]  <- str_c("ave_", c(xlab, ylab))

    temp # return the data frame
}

# =============== p-value plots ================================================
pvalue_plots <- function(results, ylim, title) {
    # Makes p-value distribution plots
        # results - results data frame
        # ylim - ymax for expanded view
        # title - plot title
    p_plot <- ggplot(results, aes(PValue)) +
        geom_histogram(bins = 100, fill = "white", color = "black") +
        geom_hline(yintercept = mean(hist(results$PValue, breaks = 100,
                                     plot = FALSE)$counts[26:100]))

    # we will need an expanded plot
    p1 <- p_plot + ggtitle(str_c(title, " p-value distribution"))
    p2 <- p_plot + coord_cartesian(xlim = c(0, 1.0), ylim = c(0, ylim)) + ggtitle("p-values expanded")
    grid.arrange(p1, p2, nrow = 2) # from gridExtra package
}

# ============= log2 fold-change distributions =================================
log2FC_plots <- function(results, range, title) {
    # Makes faceted log2FC plots by candidate
        # results - results data frame
        # range - plus/minus log2 x-axis limits
        # title - plot title
    ggplot(results, aes(x = logFC, fill = candidate)) +
        geom_histogram(binwidth=0.1, color = "black") +
        facet_wrap(~candidate) +
        ggtitle(title) +
        coord_cartesian(xlim = c(-range, range))
}

# ========== Setup for MA and volcano plots ====================================
transform <- function(results, x, y) {
    # Make data frame with some transformed columns
        # results - results data frame
        # x - columns for x condition
        # y - columns for y condition
        # return new data frame
    df <- data.frame(log10((results[x] + results[y])/2),
                     log2(results[y] / results[x]),
                     results$candidate,
                     -log10(results$FDR))
    colnames(df) <- c("A", "M", "candidate", "P")

    df # return the data frame
}

# ========== MA plots using ggplot =============================================
MA_plots <- function(results, x, y, title) {
    # makes MA-plot DE candidate ggplots
        # results - data frame with edgeR results and some condition average columns
        # x - string for x-axis column
        # y - string for y-axis column
        # title - title string to use in plots
        # returns a list of plots

    # uses transformed data
    temp <- transform(results, x, y)

    # 2-fold change lines
    ma_lines <- list(geom_hline(yintercept = 0.0, color = "black"),
                     geom_hline(yintercept = 1.0, color = "black", linetype = "dotted"),
                     geom_hline(yintercept = -1.0, color = "black", linetype = "dotted"))

    # make main MA plot
    ma <- ggplot(temp, aes(x = A, y = M)) +
        geom_point(aes(color = candidate, shape = candidate)) +
        scale_y_continuous(paste0("logFC (", y, "/", x, ")")) +
        scale_x_continuous("Ave_intensity") +
        ggtitle(title) +
        ma_lines

    # make separate MA plots
    ma_facet <- ggplot(temp, aes(x = A, y = M)) +
        geom_point(aes(color = candidate, shape = candidate)) +
        scale_y_continuous(paste0("log2 FC (", y, "/", x, ")")) +
        scale_x_continuous("log10 Ave_intensity") +
        ma_lines +
        facet_wrap(~ candidate) +
        ggtitle(str_c(title, " (separated)"))

    # make the plots visible
    print(ma)
    print(ma_facet)
}

# ========== Scatter plots using ggplot ========================================
scatter_plots <- function(results, x, y, title) {
    # makes scatter-plot DE candidate ggplots
        # results - data frame with edgeR results and some condition average columns
        # x - string for x-axis column
        # y - string for y-axis column
        # title - title string to use in plots
        # returns a list of plots

    # 2-fold change lines
    scatter_lines <- list(geom_abline(intercept = 0.0, slope = 1.0, color = "black"),
                          geom_abline(intercept = 0.301, slope = 1.0, color = "black", linetype = "dotted"),
                          geom_abline(intercept = -0.301, slope = 1.0, color = "black", linetype = "dotted"),
                          scale_y_log10(),
                          scale_x_log10())

    # make main scatter plot
    scatter <- ggplot(results, aes_string(x, y)) +
        geom_point(aes(color = candidate, shape = candidate)) +
        ggtitle(title) +
        scatter_lines

    # make separate scatter plots
    scatter_facet <- ggplot(results, aes_string(x, y)) +
        geom_point(aes(color = candidate, shape = candidate)) +
        scatter_lines +
        facet_wrap(~ candidate) +
        ggtitle(str_c(title, " (separated)"))

    # make the plots visible
    print(scatter)
    print(scatter_facet)
}

# ========== Volcano plots using ggplot ========================================
volcano_plot <- function(results, x, y, title) {
    # makes a volcano plot
        # results - a data frame with edgeR results
        # x - string for the x-axis column
        # y - string for y-axis column
        # title - plot title string

    # uses transformed data
    temp <- transform(results, x, y)

    # build the plot
    ggplot(temp, aes(x = M, y = P)) +
        geom_point(aes(color = candidate, shape = candidate)) +
        xlab("log2 FC") +
        ylab("-log10 FDR") +
        ggtitle(str_c(title, " Volcano Plot"))
}

# ============== individual protein expression plots ===========================
# function to extract the identifier part of the accesssion
get_identifier <- function(accession) {
    identifier <- str_split(accession, "\\|", simplify = TRUE)
    identifier[,3]
}

set_plot_dimensions <- function(width_choice, height_choice) {
    options(repr.plot.width=width_choice, repr.plot.height=height_choice)
}

plot_top_tags <- function(results, nleft, nright, top_tags) {
    # results should have data first, then test results (two condition summary table)
    # nleft, nright are number of data points in each condition
    # top_tags is number of up and number of down top DE candidates to plot
    # get top ipregulated
    up <- results %>%
        filter(logFC >= 0) %>%
        arrange(FDR)
    up <- up[1:top_tags, ]

    # get top down regulated
    down <- results %>%
        filter(logFC < 0) %>%
        arrange(FDR)
    down <- down[1:top_tags, ]

    # pack them
    proteins <- rbind(up, down)

    color = c(rep("red", nleft), rep("blue", nright))
    for (row_num in 1:nrow(proteins)) {
        row <- proteins[row_num, ]
        vec <- as.vector(unlist(row[1:(nleft + nright)]))
        names(vec) <- colnames(row[1:(nleft + nright)])
        title <- str_c(get_identifier(row$Acc), ", int: ", scientific(mean(vec), 2),
                       ", FDR: ", scientific(row$FDR, digits = 3),
                       ", FC: ", round(row$FC, digits = 1),
                       ", ", row$candidate)
        barplot(vec, col = color, main = title,
                cex.main = 1.0, cex.names = 0.7, cex.lab = 0.7)
    }
}

# load the IRS-normalized data and check the table
data_import <- read_tsv("labeled_grouped_protein_summary_TMT_9_IRS_normalized.txt", guess_max = 5250)

# "Filter" column flags contams and decoys
# "Missing" column flags proteins without reporter ion intensities (full sets missing)
# the table from pandas is sorted so the rows we want come first
data_all <- filter(data_import, is.na(Filter), is.na(Missing))
data_sl <- data_all %>% select(., contains("SLNorm_")) %>%
  select(., -contains("_Unused")) %>%
  select(., -contains("_Pool"))
data_irs <- data_all %>% select(., contains("IRSNorm_")) %>%
  select(., -contains("_Unused")) %>%
  select(., -contains("_Pool"))
data_pool <- data_all %>% select(., contains("_Pool_"))

# save a few columns for the results table
all_results <- data_all %>% select(., ProtGroup, Counter, Accession, Description, starts_with("PSMs_Used"))

# save gene names for edgeR so we can double check that results line up
accessions <- data_all$Accession

# see how many rows of data we have
length(accessions)

# all categories of metaplastic breast cancer tissue
mbc_sl <- select(data_sl, contains("_C"), contains("_SP"), contains("_SQ"))
mbc_irs <- select(data_irs, contains("_C"), contains("_SP"), contains("_SQ"))

# triple negative breast cancer tissue
tn_sl <- select(data_sl, contains("_TN"))
tn_irs <- select(data_irs, contains("_TN"))

# Normal tissue
n_sl <- select(data_sl, contains("_N"))
n_irs <- select(data_irs, contains("_N"))

# collect the biological replicate channels
bio_sl <- cbind(n_sl, tn_sl, mbc_sl)
bio_irs <- cbind(n_irs, tn_irs, mbc_irs)

# set a color vector for plots
color <- c(rep("red", 7), rep("blue", 6), rep("green", 14))

# boxplots
boxplot(log10(bio_sl), col = color, notch = TRUE, main = "SL Normalized data")
boxplot(log10(bio_irs), col = color, notch = TRUE, main = "IRS Normalized data")

# clustering of the replicates before IRS
plotMDS(log2(bio_sl), col = color, main = "Replicates before IRS")

# clustering after IRS
plotMDS(log2(bio_irs), col = color, main = "Replicates after IRS")

# the normal tissue samples (includes the one mis-classified sample)
pairs.panels(log10(n_sl), lm = TRUE, main = "Normal, SLNorm")
pairs.panels(log10(n_irs), lm = TRUE, main = "Normal, IRSNorm")

# the triple negative samples
pairs.panels(log10(tn_sl), lm = TRUE, main = "Triple Negative, SLNorm")
pairs.panels(log10(tn_irs), lm = TRUE, main = "Triple Negative, IRSNorm")

# the MBC C samples
pairs.panels(log10(mbc_sl[1:4]), lm = TRUE, main = "Metaplastic C, SLNorm")
pairs.panels(log10(mbc_irs[1:4]), lm = TRUE, main = "Metaplastic C, IRSNorm")

# the MBC Sp samples
pairs.panels(log10(mbc_sl[5:10]), lm = TRUE, main = "Metaplastic Sp, SLNorm")
pairs.panels(log10(mbc_irs[5:10]), lm = TRUE, main = "Metaplastic Sp, IRSNorm")

# the MBC Sq samples
pairs.panels(log10(mbc_sl[11:14]), lm = TRUE, main = "Metaplastic Sq, SLNorm")
pairs.panels(log10(mbc_irs[11:14]), lm = TRUE, main = "Metaplastic Sq, IRSNorm")

# check the pooled standards
pairs.panels(log10(data_pool[1:3]), lm = TRUE, main = "Pools, SLNorm")
pairs.panels(log10(data_pool[4:6]), lm = TRUE, main = "Pools, IRSNorm")

# put groups together into a single data frame
tmt_sl <- bio_sl
tmt_irs <- bio_irs

# define the positions of the groups
N <- 1:7
TN <- 8:13
MBC <- 14:27

# set some colors by condition
group <- c(rep("N", 7), rep("TN", 6), rep("MBC", 14))

# get the biological sample data into a DGEList object
y <- DGEList(counts = tmt_irs, group = group, genes = accessions)

# run TMM normalization (also includes a library size factor)
y <- calcNormFactors(y)

tmt_tmm <- apply_tmm_factors(y, color = color)

# check the clustering
plotMDS(y, col = color, main = "all samples after TMM")

# put CVs in data frames to simplify plots and summaries
cv_sl <- data.frame(N = CV(bio_sl[N]), TN = CV(bio_sl[TN]), MBC = CV(bio_sl[MBC]))
cv_irs <- data.frame(N = CV(bio_irs[N]), TN = CV(bio_irs[TN]), MBC = CV(bio_irs[MBC]))
cv_tmm <- data.frame(N = CV(tmt_tmm[N]), TN = CV(tmt_tmm[TN]), MBC = CV(tmt_tmm[MBC]))

# see what the median CV values are
medians <- apply(cv_sl, 2, FUN = median)
print("SLNorm median CVs by condition (%)")
round(medians, 2)

medians <- apply(cv_irs, 2, FUN = median)
print("IRSNorm median CVs by condition (%)")
round(medians, 2)

medians <- apply(cv_tmm, 2, FUN = median)
print("Final median CVs by condition (%)")
round(medians, 2)

# see what the CV distibutions look like
# need long form for ggplot
long_cv_sl <- gather(cv_sl, key = "group", value = "cv")

# traditional boxplots
ggplot(long_cv_sl, aes(x = group, y = cv, fill = group)) +
  geom_boxplot(notch = TRUE) +
  ggtitle("SL CV distributions")

# density plots
ggplot(long_cv_sl, aes(x = cv, color = group)) +
  geom_density() +
  coord_cartesian(xlim = c(0, 200)) +
  ggtitle("SL CV distributions")

# need long form for ggplot
long_cv_tmm <- gather(cv_tmm, key = "group", value = "cv")

# traditional boxplots
ggplot(long_cv_tmm, aes(x = group, y = cv, fill = group)) +
  geom_boxplot(notch = TRUE) +
  ggtitle("Final CV distributions")

# density plots
ggplot(long_cv_tmm, aes(x = cv, color = group)) +
  geom_density() +
  coord_cartesian(xlim = c(0, 200)) +
  ggtitle("Final CV distributions")

# compute dispersions and plot BCV
y <- estimateDisp(y)
plotBCV(y, main = "BCV plot of IRS/TMM normalized data")

# the exact test object has columns like fold-change, CPM, and p-values
et <- exactTest(y, pair = c("N", "TN"))

# this counts up, down, and unchanged genes (proteins) at 10% FDR
summary(decideTestsDGE(et, p.value = 0.10))

# the topTags function adds the BH FDR values to an exactTest data frame
# make sure we do not change the row order (the sort.by parameter)!
topTags(et)$table
tt <- topTags(et, n = Inf, sort.by = "none")

# make an MD plot (like MA plot)
plotMD(et, p.value = 0.10)
abline(h = c(-1, 1), col = "black")

# check the p-value distribution
ggplot(tt$table, aes(PValue)) +
  geom_histogram(bins = 100, fill = "white", color = "black") +
  geom_hline(yintercept = mean(hist(et$table$PValue, breaks = 100,
                                    plot = FALSE)$counts[26:100])) +
  ggtitle("N versus TN p-value distribution")

# get the results summary
results <- collect_results(tmt_tmm, tt$table, N, "N", TN, "TN")

# make column names unique by adding comparison (for the accumulated frame)
results_temp  <- results
colnames(results_temp) <- str_c(colnames(results), "_N_TN")

# accumulate the testing results
all_results <- cbind(all_results, results_temp)

# see how many candidates by category
results %>% count(candidate)

# plot log2 fold-changes by category
ggplot(results, aes(x = logFC, fill = candidate)) +
  geom_histogram(binwidth=0.1, color = "black") +
  facet_wrap(~candidate) +
  coord_cartesian(xlim = c(-4, 4)) +
  ggtitle("N vs TN logFC distributions by candidate")

# make MA plots
MA_plots(results, "ave_N", "ave_TN", "N vs TN")

# make scatter plots
scatter_plots(results, "ave_N", "ave_TN", "N vs TN")

# make a volcano plot
volcano_plot(results, "ave_N", "ave_TN", "N vs TN")

# look at the top 20 candidates in each direction (up in TN, then down in TN)
set_plot_dimensions(6, 3.5)
plot_top_tags(results, 7, 6, 20)
set_plot_dimensions(7, 7)

# the exact test object has columns like fold-change, CPM, and p-values
et <- exactTest(y, pair = c("N", "MBC"))

# this counts up, down, and unchanged genes (proteins) at 10% FDR
summary(decideTestsDGE(et, p.value = 0.10))

# the topTags function adds the BH FDR values to an exactTest data frame
# make sure we do not change the row order (the sort.by parameter)!
topTags(et)$table
tt <- topTags(et, n = Inf, sort.by = "none")

# make an MD plot (like MA plot)
plotMD(et, p.value = 0.10)
abline(h = c(-1, 1), col = "black") # 2-fold change lines

# check the p-value distribution
ggplot(tt$table, aes(PValue)) +
  geom_histogram(bins = 100, fill = "white", color = "black") +
  geom_hline(yintercept = mean(hist(et$table$PValue, breaks = 100,
                                    plot = FALSE)$counts[26:100])) +
  ggtitle("N vs MBC p-value distribution")

# get the results summary
results <- collect_results(tmt_tmm, tt$table, N, "N", MBC, "MBC")

# make column names unique by adding comparison
results_temp  <- results
colnames(results_temp) <- str_c(colnames(results), "_N_MBC")

# accumulate the testing results
all_results <- cbind(all_results, results_temp)

# see how many candidates by category
results %>% count(candidate)

# plot log2 fold-changes by category
ggplot(results, aes(x = logFC, fill = candidate)) +
  geom_histogram(binwidth=0.1, color = "black") +
  facet_wrap(~candidate) +
  coord_cartesian(xlim = c(-4, 4)) +
  ggtitle("N vs MBC logFC distributions by candidate")

# make MA plots
MA_plots(results, "ave_N", "ave_MBC", "N vs MBC")

# make scatter plots
scatter_plots(results,  "ave_N", "ave_MBC", "N vs MBC")

# make a volcano plot
volcano_plot(results,  "ave_N", "ave_MBC", "N vs MBC")

# look at the top 20 candidates (up in MBC, then down in MBC)
set_plot_dimensions(6, 3.5)
plot_top_tags(results, 7, 14, 20)
set_plot_dimensions(7, 7)

# the exact test object has columns like fold-change, CPM, and p-values
et <- exactTest(y, pair = c("TN", "MBC"))

# this counts up, down, and unchanged genes (proteins) at 10% FDR
summary(decideTestsDGE(et, p.value = 0.10))

# the topTags function adds the BH FDR values to an exactTest data frame
# make sure we do not change the row order (the sort.by parameter)!
topTags(et)$table
tt <- topTags(et, n = Inf, sort.by = "none")

# make an MD plot (like MA plot)
plotMD(et, p.value = 0.10)
abline(h = c(-1, 1), col = "black")

# check the p-value distribution
ggplot(tt$table, aes(PValue)) +
  geom_histogram(bins = 100, fill = "white", color = "black") +
  geom_hline(yintercept = mean(hist(et$table$PValue, breaks = 100,
                                    plot = FALSE)$counts[26:100])) +
  ggtitle("TN vs MBC p-value distribution")

# get the results summary
results <- collect_results(tmt_tmm, tt$table, TN, "TN", MBC, "MBC")

# make column names unique by adding comparison
results_temp  <- results
colnames(results_temp) <- str_c(colnames(results), "_TN_MBC")

# accumulate the testing results
all_results <- cbind(all_results, results_temp)

# see how many candidates by category
results %>% count(candidate)

# plot log2 fold-changes by category
ggplot(results, aes(x = logFC, fill = candidate)) +
  geom_histogram(binwidth=0.1, color = "black") +
  facet_wrap(~candidate) +
  coord_cartesian(xlim = c(-4, 4)) +
  ggtitle("TN vs MBC logFC distributions by candidate")

# make MA plots
MA_plots(results, "ave_TN", "ave_MBC", "TN vs MBC")

# make scatter plots
scatter_plots(results, "ave_TN", "ave_MBC", "TN vs MBC")

# make a volcano plot
volcano_plot(results, "ave_TN", "ave_MBC", "TN vs MBC")

# look at the top 10 candidates (up in MBC, then down in MBC)
set_plot_dimensions(6, 3.5)
plot_top_tags(results, 6, 14, 10)
set_plot_dimensions(7, 7)

# write the results to disk
write.table(all_results, "three_tissues_results.txt", sep = "\t",
           row.names = FALSE, na =  " ")

# log the session details
sessionInfo()


wtd.cor <- function(x, y=NULL, weight=NULL, mean1=TRUE, collapse=TRUE, bootse=FALSE, bootp=FALSE, bootn=1000){
    x <- as.matrix(x)
    xnm <- colnames(x)
    if(is.null(weight)){
        weight <- rep(1, dim(x)[1])
    }
    if(bootse==FALSE & bootp==TRUE)
        warning("bootp can only be used with bootstrapped standard errors")
    if(mean1==TRUE)
        weight <- weight/mean(weight, na.rm=TRUE)
    if(is.null(y)){
        y <- x
    }
    y <- as.matrix(y)
    ynm <- colnames(y)
    if(is.null(xnm))
        xnm <- "X"
    if(is.null(ynm))
        ynm <- "Y"
    if(dim(x)[1]!=dim(y)[1])
        stop("Cannot Correlate Variables of Different Lengths")
    if(bootse==FALSE){
      materset <- lapply(as.data.frame(x), function(x) lapply(as.data.frame(y), function(y) onecor.wtd(x, y, weight)))
      est <- sapply(materset, function(q) sapply(q, function(g) g[1]))
      se <- sapply(materset, function(q) sapply(q, function(g) g[2]))
      tval <- sapply(materset, function(q) sapply(q, function(g) g[3]))
      pval <- sapply(materset, function(q) sapply(q, function(g) g[4]))
      out <- list(correlation=est, std.err=se, t.value=tval, p.value=pval)
  }
  if(bootse==TRUE){
      est <- as.matrix(wtd.cors(x, y, weight))
      samps <- lapply(1:bootn, function(g) sample(1:dim(x)[1], round(sum(weight, na.rm=TRUE), 0), replace=TRUE, prob=weight))
      corset2 <- lapply(samps, function(q) as.matrix(cor(x[q,], y[q,], use="pairwise.complete.obs")))
      eachcor <- lapply(1:dim(est)[1], function(a) sapply(1:dim(est)[2], function(b) unlist(sapply(corset2, function(g) g[a,b]))))
      est2 <- sapply(eachcor, function(a) colMeans(a))
      se <- sapply(eachcor, function(a) sqrt(apply(a, 2, var)))
      tval <- est2/se
      pval <- pchisq(tval^2, 1, lower.tail=FALSE)
      if(bootp==TRUE)
          pval <- sapply(eachcor, function(a) apply(a, 2, function(x) 2*min(c(sum(x>0 & !is.na(x))/sum(!is.na(x)), sum(x<0 & !is.na(x))/sum(!is.na(x))))))
      if(length(ynm)>1 & length(xnm)>1){
          colnames(est2) <- colnames(se) <- colnames(tval) <- colnames(pval) <- xnm
          rownames(est2) <- rownames(se) <- rownames(tval) <- rownames(pval) <- ynm
      }
      out <- list(correlation=t(est), bootcor=est2, std.err=se, t.value=tval, p.value=pval)
  }
    if(is.vector(est) & collapse==TRUE || (1 %in% dim(est)) & collapse==TRUE){ #Fix Section
        outpre <- out
        if(bootse==FALSE)
            out <- matrix(unlist(out), ncol=4, byrow=FALSE)
        if(bootse==TRUE)
            out <- matrix(unlist(out), ncol=5, byrow=FALSE)
        nom <- xnm
        if(length(xnm)==1)
            nom <- ynm
        rownames(out) <- nom
        colnames(out) <- names(outpre)
    }
    out
}


#install.packages("jsonlite", repos='http://cran.us.r-project.org')
library(jsonlite)
library(clValid)
library(amap)
#library(sp)
library(ape)
library(flashClust)
library(fpc)
library(cluster)

mean_m = function(vec){
    vec[as.vector(is.nan(vec))] <- NA
    n <- sum(!is.na(vec))
    summ <- sum(vec,na.rm=TRUE)
    summ/n
}

naToNaN = function(x) {
    x[is.na(x)] <- NaN
    return(x)
}

rowVar <- function(x) {
	rowSums((x - rowMeans(x))^2)/(dim(x)[2] - 1)
}

topVarGenes = function(matx,count){
	matv<-head(order(rowVar(matx),decreasing=TRUE),count)
	matx<-matx[matv,]
	return(matx)
}

calc_cluster_props = function(logratios_median, cluster, ret) {
    ###mean pairwise correlation
    meancor <- c()
    for(i in 1:max(cluster)) {
        clust_ind <- which(cluster == i)
        if (length(clust_ind) == 1) {
            meancor <- c(meancor, NA)
        } else {
            cors <- cor(t(logratios_median[clust_ind,]), use="pairwise.complete.obs",method="pearson")
            AbCorC <- mean(cors[lower.tri(cors, diag=FALSE)])
            meancor <- c(meancor, AbCorC)
        }
    }
    #print(meancor)
    meancor <- naToNaN(meancor)

    ###MSEC
    MSECs <- c()
    for(i in 1:max(cluster)) {
        clust_ind <- which(cluster == i)
        if (length(clust_ind) == 1) {
            MSECs <- c(MSECs, NA)
        } else {
            curdata <- logratios_median[clust_ind,]
            MSEall <- mean_m((curdata-mean_m(curdata))^2)
            cmeans <- colMeans(curdata,na.rm=TRUE)
            csds <- apply(curdata,2,sd,na.rm=TRUE)
            MSEC <- mean_m((sweep(curdata,2,cmeans))^2/MSEall)
            MSECs <- c(MSECs, MSEC)
        }
    }
    #print(MSECs)
    MSECs <- naToNaN(MSECs)

    ret[["meancor"]] <- meancor
    ret[["msecs"]] <- MSECs
    return(ret)
}

clusters_from_dendrogram = function(values, dendrogram, height_cutoff) {
    hcout <- as.hclust.phylo(read.tree(text=dendrogram))
    pdf("/kb/module/work/hcout.pdf", width=8.5, height=11)
    plot(hcout)
    groups <- cutree(hcout, h=height_cutoff)
    names <- names(groups)
    cluster_labels <- numeric(nrow(values))
    for (pos in 1:length(cluster_labels)) {
        cluster_labels[pos] <- -1
    }
    for (pos in 1:length(groups)) {
        name <- as.integer(names[pos])
        value <- as.integer(groups[pos])
        cluster_labels[name + 1] <- value
    }
    return(calc_cluster_props(values, cluster_labels, list(cluster_labels=cluster_labels,
        dendrogram=unbox(dendrogram))))
}

methods <- list()

methods[["ClusterServiceR.estimate_k"]] <- function(matrix, min_k, max_k,
        max_iter, random_seed, neighb_size, max_items) {
    if (!is.null(random_seed))
        set.seed(random_seed)
    if (is.null(min_k))
        min_k <- 2
    if (is.null(max_k))
        max_k <- 200
    if (is.null(max_iter))
        max_iter <- 100
    if (is.null(neighb_size))
        neighb_size <- 10
    values <- matrix[["values"]]
    #row_names <- matrix[["row_ids"]]
    row_names <- c(1:length(matrix[["row_ids"]]))-1
    row.names(values) <- row_names
    values <- data.matrix(values)
    if ((!is.null(max_items)) && (max_items < nrow(values))) {
        row_nums <- sample(1:nrow(values), max_items, replace=FALSE)
        values <- values[row_nums,]
    }
    max_clust_num = min(c(max_k,nrow(values)-1))
    valid <- clValid(values, nClust=c(min_k:max_clust_num), maxitems=nrow(values),
        clMethods=c("kmeans"),validation=c("internal"), iter.max=max_iter,
        neighbSize=neighb_size)
    ret <- measures(valid, "Silhouette")[1,,1]
    ret_names <- names(ret)
    best_pos <- which.max(ret)
    cluster_count_qualities <- list()
    for (pos in 1:length(ret)) {
        cluster_count <- unbox(ret_names[pos])
        quality <- unbox(ret[pos])
        cluster_count_qualities <- rbind(cluster_count_qualities, list(cluster_count, quality))
    }
    return(list(best_k=unbox(as.numeric(ret_names[best_pos])), estimate_cluster_sizes=cluster_count_qualities))
}

methods[["ClusterServiceR.estimate_k_new"]] <- function(matrix, min_k, max_k,
       crit,usepam,alpha,diss,random_seed) {
    if (!is.null(random_seed))
        set.seed(random_seed)
    if (is.null(min_k))
        min_k <- 2
    if (is.null(max_k))
        max_k <- 200
    if (is.null(crit))
        crit <- "asw"
    if (is.null(usepam))
        usepam <- FALSE
    values <- matrix[["values"]]
    #row_names <- matrix[["row_ids"]]
    row_names <- c(1:length(matrix[["row_ids"]]))-1
    row.names(values) <- row_names
    values <- data.matrix(values)
    max_clust_num = min(c(max_k,nrow(values)-1))
    pk<- pamk(values,krange=c(min_k:max_clust_num),criterion=crit,
        usepam=usepam,ns=10)
    ret_names <- c(min_k:max_clust_num)
    best_pos <- pk$nc
    cluster_count_qualities <- list()
    for (pos in 1:length(ret_names)) {
        cluster_count = unbox(ret_names[pos])
        quality <- unbox(pk$crit[cluster_count])
        cluster_count_qualities <- rbind(cluster_count_qualities, list(cluster_count, quality))
    }
    return(list(best_k=unbox(as.numeric(best_pos)), estimate_cluster_sizes=cluster_count_qualities))
}

methods[["ClusterServiceR.cluster_k_means"]] <- function(matrix, k, n_start,
        max_iter, random_seed, algorithm_name) {
    if (is.null(n_start))
        n_start <- 1000
    if (is.null(max_iter))
        max_iter <- 1000
    if (is.null(algorithm_name))
        algorithm_name <- "Lloyd"
    values <- matrix[["values"]]
    #row_names <- matrix[["row_ids"]]
    row_names <- c(1:length(matrix[["row_ids"]]))-1
    row.names(values) <- row_names
    values <- data.matrix(values)
    #col_ids <- matrix[["col_ids"]]
    if (!is.null(random_seed))
        set.seed(random_seed)
    km <- kmeans(values, k, iter.max = max_iter, nstart=n_start, algorithm=algorithm_name)
    return(calc_cluster_props(values, km[["cluster"]], list(cluster_labels=km[["cluster"]])))
}

methods[["ClusterServiceR.cluster_hierarchical"]] <- function(matrix,
        distance_metric, linkage_criteria, height_cutoff,
        process_rows, algorithm) {
    values <- matrix[["values"]]
    row_names <- c(1:length(matrix[["row_ids"]]))-1
    row.names(values) <- row_names
    if (is.null(process_rows))
        process_rows<-nrow(matrix[["values"]])
    original_values <- values
    values <- data.matrix(topVarGenes(values,process_rows))
    hcout <- NA
    if (is.null(algorithm) || algorithm == "hclust") {
        hcout <- hcluster(values, method="correlation")
    } else {
        dd <- Dist(values, method="correlation")
        hcout <- flashClust::hclust(dd, method = "complete")
    }
    phylo <- as.phylo(hcout)
    phylo$edge.length <- phylo$edge.length / max(hcout$height)
    newick <- write.tree(phylo, file = "")
    #print(is.ultrametric(tree))
    #print(is.binary.tree(tree))
    #print(is.rooted(tree))
    return(clusters_from_dendrogram(original_values, newick, height_cutoff))
}

methods[["ClusterServiceR.clusters_from_dendrogram"]] <- function(
        matrix, dendrogram, height_cutoff) {
    values <- matrix[["values"]]
    row_names <- c(1:length(matrix[["row_ids"]]))-1
    row.names(values) <- row_names
    values <- data.matrix(values)
    return(clusters_from_dendrogram(values, dendrogram, height_cutoff))
}

methods[["ClusterServiceR.calc_cluster_qualities"]] <- function(
        matrix, cluster_labels) {
    values <- matrix[["values"]]
    row_names <- c(1:length(matrix[["row_ids"]]))-1
    row.names(values) <- row_names
    values <- data.matrix(values)
    return(calc_cluster_props(values, cluster_labels, list(cluster_labels=cluster_labels)))
}

tryCatch({
    args <- commandArgs(trailingOnly = TRUE)
    input <- fromJSON(args[1], flatten=TRUE, simplifyDataFrame=FALSE,
        simplifyVector=TRUE, simplifyMatrix=TRUE)
    params <- input[["params"]]
    if (class(params) != "list") {
        input <- fromJSON(args[1], flatten=TRUE, simplifyDataFrame=FALSE,
            simplifyVector=FALSE, simplifyMatrix=FALSE)
        params <- input[["params"]]
    }
    method <- input[["method"]]
    func <- methods[[method]]
    if ( is.null(func) ) {
        stop(paste("ERROR: Function wasn't found: ", method))
    }
    ret <- do.call(func, params)
    output <- toJSON(list(version=unbox("1.1"),result=list(ret)))
    write(output, file=args[2])
}, error = function(err) {
    msg <- paste("ERROR: ", err)
    print(msg)
    output <- toJSON(list(version=unbox("1.1"),error=list(error=unbox(""),
        name=unbox("JSONRPCError"),code=unbox(-32603),message=unbox(msg))))
    write(output, file=args[2])
}, finally = {
})


BASIN_CLIMATE_AVERAGING <- function(climateData) {

	num_site <- 1
	DATA <- climateData
	YEAR <- DATA[,1]
	MONTH <- DATA[,2]
	DAY <- DATA[,3]

	SITE_PRCP <- DATA[,4]
	SITE_TMAX <- DATA[,5]
	SITE_TMIN <- DATA[,6]
	no_leap <- which(DAY!=29 | MONTH!=2)

	PRCP <- SITE_PRCP[no_leap]
	TMAX <- SITE_TMAX[no_leap]
	TMIN <- SITE_TMIN[no_leap]
	TEMP <- (TMAX + TMIN)/2

	#Create Time Set
	YEAR_D <- DATA[no_leap,1]
	MONTH_D <-  DATA[no_leap,2]
	DAY_D <- DATA[no_leap,3]

	allData <- cbind(YEAR_D,MONTH_D,DAY_D,PRCP,TMAX,TMIN,TEMP)

	#MONTHLY VARIABLES
	MONTHLY_DATES <- aggregate(allData[,4],FUN=sum,by=list(allData[,2],allData[,1]))[,1:2]
	MONTHLY_PRCP <- aggregate(allData[,4],FUN=sum,by=list(allData[,2],allData[,1]))[,3]
	MONTHLY_TMAX <- aggregate(allData[,5],FUN=mean,by=list(allData[,2],allData[,1]))[,3]
	MONTHLY_TMIN <- aggregate(allData[,6],FUN=mean,by=list(allData[,2],allData[,1]))[,3]
	MONTHLY_TEMP <- aggregate(allData[,7],FUN=mean,by=list(allData[,2],allData[,1]))[,3]

	PRCP <- MONTHLY_PRCP[1:(length(MONTHLY_PRCP))]
	TMAX <- MONTHLY_TMAX[1:(length(MONTHLY_PRCP))]
	TMIN <- MONTHLY_TMIN[1:(length(MONTHLY_PRCP))]
	TEMP <- MONTHLY_TEMP[1:(length(MONTHLY_PRCP))]

	return(cbind(MONTHLY_DATES,PRCP,TMAX,TMIN,TEMP))

}


<<<<<<< HEAD
#### Healthy Neighborhoods Project: Using Ecological Data to Improve Community Health
### Cedric subproject: Developing better ways to measure equity in health
## Florida Charts Census Tract Mortality Data: The R Project for Statistical Computing Script by DrewC!

#### Section A: Prepare Code

### Step 1: Import Libraries and Import Dataset

## Open R Terminal
R # open R in VS Code (any terminal)
library(skimr) # Library used for easy summary of data

## Import Standard Libraries
library(tidyverse)
library(skimr)

## Import Machine Learning Libraries
library(randomForest) # Popular random forest package for R

## Import Statistics Libraries
library(MASS) # Stepwise inclusion model with linear and logistic options
library(pROC) # ROC tests with AUC output
library(psych) # Survey analysis library with factor analysis
library(GPArotation) # Rotation options for factor analysis

## Import Data
setwd("C:/Users/drewc/GitHub/Hope") # Set wd to project repository
df_yrbs = read.csv("_data/flcharts_50_dm2.csv.csv") # Import dataset from _data folder
skim(df_yrbs) # Descritive statistics, dimensions, and missing values

### Step 2: Prepare Data for Classificaiton

## Resolve missing data
df_yrbs = subset(df_yrbs, select = -c(qn10, qn11, qn21, qn22, qn28, qn29, qn45)) # Remove variables with high missing values
df_yrbs = na.omit(df_yrbs) # Omit rows with NA from Data Frame
df_yrbs[df_yrbs == 2] = 0 # Change all "No" Responses of 2 to 0

## Subset for outcome of interest
df_yrbs$outcome <- 0 # Add new outcome column and set value to 0
df_yrbs$outcome[df_yrbs$qn26 == 1 | df_yrbs$qn27 == 1] <- 1 # Create new column based on conditions
df_plan = subset(df_yrbs, select = -c(qn26, qn27)) # Remove outcome and variables similar to the outcome

## Verify Data
head(df_plan) # Mini table with top 5 observations
dim(df_plan) # Dimensions of data frame

#### Section B: Vairable Selection using Quantitative and Qualitative Methods

### Step 3: Conduct Factor Analysis to Identify Latent Variables

## Subset by group with outcome
df_fa = subset(df_plan, outcome == "1") # Subset for outcome of interest
df_fa = subset(df_fa, select = -(outcome)) # Remove outcome variable
nrow(df_fa) # Check number of rows

## Perform Scree test and loadings
model_scree = fa.parallel(df_fa) # Create scree plot to determine number of latent variables
print(model_scree)

## Write Factor Analysis Output to File
result = model_scree # Save result df to variable
file = file("risk_yrbs_rf_factor_log_auc_results.txt") # Open result file in subproject repository
open(file, "w") # Open file and "a" to append
write("Eigenvalues from Factor Analysis",  file) # Insert title
write(" ", file) # Insert space below title
capture.output(result, file = file, append = TRUE) # write summary to file
write(" ", file) # Insert space below result
close(file) # Close file

### Step 4: Use a Random Forest to rank variables by importance

## Create a Random Forest
forest = randomForest(formula = outcome ~ ., data = df_plan, ntree = 1000, importance = TRUE) # This will take time
summary(forest) # Summary of forest model

## Tidy Results for Variable Classification
mat_forest = round(importance(forest), 2) # Round importance outcomes to two places,
df_forest = as.data.frame(mat_forest) # Save as data frame
df_forest = rownames_to_column(df_forest)
colnames(df_forest) <- c("Variable", "MSE", "Gini") # Change column names to easily readible. Both values correspond to the summed increse in either Mean Squared Error or Gini as the variable is removed. Both are important and used elsewhere in randomforests (Scikit-learn).
skim(df_forest) # Descritive statistics, dimensions, and missing values

## Create Importance Variable Lists
df_rank = df_forest[which(df_forest$MSE > 8.37 & df_forest$Gini > 9.26), ] # Save all variables with importance value above column average
df_rank = arrange(df_rank, desc(MSE, Gini)) # Descend by variable in data frame
print(df_rank) # Print output

## Write Random Forest Output to File
result = print(df_rank) # Save result df to variable
file = file("risk_yrbs_rf_factor_log_auc_results.txt") # Open result file in subproject repository
open(file, "a") # Open file and "w" to overwrite
write("Random Forest Variable Classification", file) # Insert title
write(" ", file) # Insert space below title
write.table(result, file, quote = FALSE, sep = "   ") # write table of values to filee
write(" ", file) # Insert space below result
close(file) # Close file

## Create list of variables for input
df_quant = df_rank["Variable"]
char_qual = c("qn13", "qn20", "qn24", "qn25", "qn46", "qn47", "qn50", "qn52", "qn58", "qn59", "qn69")
df_qual["Variable"] = char_qual
df_vars = merge(df_quant, df_qual, by = "Variable", all.x = TRUE, all.y = TRUE) # Merge data frames by column, keeping all of X
paste(df_vars$Variable, collapse = " + ") # Paste + into variable string for Mixed-Method variables combing both above lists

## Write Variable Selection Output to File
result1 = print(char_qual) # Save result df to variable
result2 = print(paste(df_vars$Variable, collapse = " + ")) # Save result df to variable
file = file("risk_yrbs_rf_factor_log_auc_results.txt") # Open result file in subproject repository
open(file, "a") # Open file and "w" to overwrite
write("Qualitative variables Selected", file) # Insert space below title
capture.output(result1, file = file, append = TRUE) # write summary to file
write(" ", file) # Insert space below title
write("Mixed Method Variable Selection Results", file) # Insert title
capture.output(result2, file = file, append = TRUE) # write summary to file
write(" ", file) # Insert space below title
close(file) # Close file

#### Section C: Build Regression Model and Risk Score for Validation

### Step 5: Logistic Regression with Stepwise Selection for Final Model

## Create training and validation set
sample = sample.int(n = nrow(df_plan), size = floor(.50*nrow(df_plan)), replace = F) # Create training and testing dataset with 50% split
train = df_plan[sample, ] # Susbset data frame by sample
test = df_plan[-sample, ] # Subset data frame by removing sample

## Perform Logisitc Regression on selected variables
model_logistic = glm(outcome ~ qn13 + qn19 + qn20 + qn23 + qn24 + qn25 + qn40 + qn46 + qn47 + qn50 + qn52 + qn56 + qn58 + qn59 + qn68 + qn69, data = train)
summary(model_logistic)

## Stepwise backward selection
model_back = stepAIC(model_logistic, direction = "backward") # Stepwise backwards selection on model
summary(model_back) # Output model summary and check for variables to remove for final model
qn13 + qn19 + qn20 + qn23 + qn24 + qn25 + qn50 + qn56 + qn68 # Remove variables not included or signficiant in stepwise

## Final Model and AUC Score
model_final = glm(outcome~ qn13 + qn19 + qn20 + qn23 + qn24 + qn25 + qn50 + qn56 + qn68, data = train) # Perform logistic regression model on selected variables on test data
roc_train = roc(model_final$y, model_final$fitted.values, ci = T, plot = T) # Perform ROC test on test data
auc(roc_test) # Print AUC score

## Write Quantitative Selection Model Output to File
result1 = print(summary(model_back)) # Save result df to variable
result2 = print(summary(model_final)) # Save result df to variable
result3 = print(auc(roc_train)) # Save result df to variable
file = file("risk_yrbs_rf_factor_log_auc_results.txt") # Open result file in subproject repository
open(file, "a") # Open file and "a" to append
write("Backwards Stepwise Logistic Regression Model", file) # Insert space below title
write(" ", file) # Insert space below title
write("Final Model for Risk Score", file) # Insert space below title
write(" ", file) # Insert space below title
write("Training Model", file) # Insert space below title
capture.output(result3, file = file, append = TRUE) # write summary to file
write(" ", file) # Insert space below title
close(file) # Close file

### Step 5: Logistic Regression with Stepwise Selection for Final Model

## Develop Risk Score Variable

# Create new column based on conditions
test$hope <- 0 # Add new outcome column and set value to 0
test$hope <- 3.5*test$qn25 + 1.25*test$qn13 + test$qn19 + 1.5*test$qn20 + test$qn23 + test$qn50 + 0.75*test$qn68 + 0.75*test$qn56 + 0.5*test$qn24

## Final Model and AUC Score
model_test = glm(outcome~ hope, data = test) # Perform logistic regression model on selected variables on test data
roc_test = roc(model_test$y, model_test$fitted.values, ci = T, plot = T) # Perform ROC test on test data
auc(roc_test) # Print AUC score

## Write Quantitative Selection Model Output to File
result = print(auc(roc_test)) # Save result df to variable
file = file("risk_yrbs_rf_factor_log_auc_results.txt") # Open result file in subproject repository
open(file, "a") # Open file and "a" to append
write("Hope Score Validation", file) # Insert space below title
capture.output(result, file = file, append = TRUE) # write summary to file
write(" ", file) # Insert space below title
close(file) # Close file
=======
#### Healthy Neighborhoods Project: Using Ecological Data to Improve Community Health
### Cedric subproject: Developing better ways to measure equity in health
## Florida Charts Census Tract Mortality Data: The R Project for Statistical Computing Script by DrewC!

#### Section A: Prepare Code

### Step 1: Import Libraries and Import Dataset

## Open R Terminal
R # open R in VS Code (any terminal)
library(skimr) # Library used for easy summary of data

## Import Standard Libraries
library(tidyverse)
library(skimr)

## Import Machine Learning Libraries
library(randomForest) # Popular random forest package for R

## Import Statistics Libraries
library(MASS) # Stepwise inclusion model with linear and logistic options
library(pROC) # ROC tests with AUC output
library(psych) # Survey analysis library with factor analysis
library(GPArotation) # Rotation options for factor analysis

## Import Data
setwd("C:/Users/drewc/GitHub/Hope") # Set wd to project repository
df_yrbs = read.csv("_data/flcharts_50_dm2.csv.csv") # Import dataset from _data folder
skim(df_yrbs) # Descritive statistics, dimensions, and missing values

### Step 2: Prepare Data for Classificaiton

## Resolve missing data
df_yrbs = subset(df_yrbs, select = -c(qn10, qn11, qn21, qn22, qn28, qn29, qn45)) # Remove variables with high missing values
df_yrbs = na.omit(df_yrbs) # Omit rows with NA from Data Frame
df_yrbs[df_yrbs == 2] = 0 # Change all "No" Responses of 2 to 0

## Subset for outcome of interest
df_yrbs$outcome <- 0 # Add new outcome column and set value to 0
df_yrbs$outcome[df_yrbs$qn26 == 1 | df_yrbs$qn27 == 1] <- 1 # Create new column based on conditions
df_plan = subset(df_yrbs, select = -c(qn26, qn27)) # Remove outcome and variables similar to the outcome

## Verify Data
head(df_plan) # Mini table with top 5 observations
dim(df_plan) # Dimensions of data frame

#### Section B: Vairable Selection using Quantitative and Qualitative Methods

### Step 3: Conduct Factor Analysis to Identify Latent Variables

## Subset by group with outcome
df_fa = subset(df_plan, outcome == "1") # Subset for outcome of interest
df_fa = subset(df_fa, select = -(outcome)) # Remove outcome variable
nrow(df_fa) # Check number of rows

## Perform Scree test and loadings
model_scree = fa.parallel(df_fa) # Create scree plot to determine number of latent variables
print(model_scree)

## Write Factor Analysis Output to File
result = model_scree # Save result df to variable
file = file("risk_yrbs_rf_factor_log_auc_results.txt") # Open result file in subproject repository
open(file, "w") # Open file and "a" to append
write("Eigenvalues from Factor Analysis",  file) # Insert title
write(" ", file) # Insert space below title
capture.output(result, file = file, append = TRUE) # write summary to file
write(" ", file) # Insert space below result
close(file) # Close file

### Step 4: Use a Random Forest to rank variables by importance

## Create a Random Forest
forest = randomForest(formula = outcome ~ ., data = df_plan, ntree = 1000, importance = TRUE) # This will take time
summary(forest) # Summary of forest model

## Tidy Results for Variable Classification
mat_forest = round(importance(forest), 2) # Round importance outcomes to two places,
df_forest = as.data.frame(mat_forest) # Save as data frame
df_forest = rownames_to_column(df_forest)
colnames(df_forest) <- c("Variable", "MSE", "Gini") # Change column names to easily readible. Both values correspond to the summed increse in either Mean Squared Error or Gini as the variable is removed. Both are important and used elsewhere in randomforests (Scikit-learn).
skim(df_forest) # Descritive statistics, dimensions, and missing values

## Create Importance Variable Lists
df_rank = df_forest[which(df_forest$MSE > 8.37 & df_forest$Gini > 9.26), ] # Save all variables with importance value above column average
df_rank = arrange(df_rank, desc(MSE, Gini)) # Descend by variable in data frame
print(df_rank) # Print output

## Write Random Forest Output to File
result = print(df_rank) # Save result df to variable
file = file("risk_yrbs_rf_factor_log_auc_results.txt") # Open result file in subproject repository
open(file, "a") # Open file and "w" to overwrite
write("Random Forest Variable Classification", file) # Insert title
write(" ", file) # Insert space below title
write.table(result, file, quote = FALSE, sep = "   ") # write table of values to filee
write(" ", file) # Insert space below result
close(file) # Close file

## Create list of variables for input
df_quant = df_rank["Variable"]
char_qual = c("qn13", "qn20", "qn24", "qn25", "qn46", "qn47", "qn50", "qn52", "qn58", "qn59", "qn69")
df_qual["Variable"] = char_qual
df_vars = merge(df_quant, df_qual, by = "Variable", all.x = TRUE, all.y = TRUE) # Merge data frames by column, keeping all of X
paste(df_vars$Variable, collapse = " + ") # Paste + into variable string for Mixed-Method variables combing both above lists

## Write Variable Selection Output to File
result1 = print(char_qual) # Save result df to variable
result2 = print(paste(df_vars$Variable, collapse = " + ")) # Save result df to variable
file = file("risk_yrbs_rf_factor_log_auc_results.txt") # Open result file in subproject repository
open(file, "a") # Open file and "w" to overwrite
write("Qualitative variables Selected", file) # Insert space below title
capture.output(result1, file = file, append = TRUE) # write summary to file
write(" ", file) # Insert space below title
write("Mixed Method Variable Selection Results", file) # Insert title
capture.output(result2, file = file, append = TRUE) # write summary to file
write(" ", file) # Insert space below title
close(file) # Close file

#### Section C: Build Regression Model and Risk Score for Validation

### Step 5: Logistic Regression with Stepwise Selection for Final Model

## Create training and validation set
sample = sample.int(n = nrow(df_plan), size = floor(.50*nrow(df_plan)), replace = F) # Create training and testing dataset with 50% split
train = df_plan[sample, ] # Susbset data frame by sample
test = df_plan[-sample, ] # Subset data frame by removing sample

## Perform Logisitc Regression on selected variables
model_logistic = glm(outcome ~ qn13 + qn19 + qn20 + qn23 + qn24 + qn25 + qn40 + qn46 + qn47 + qn50 + qn52 + qn56 + qn58 + qn59 + qn68 + qn69, data = train)
summary(model_logistic)

## Stepwise backward selection
model_back = stepAIC(model_logistic, direction = "backward") # Stepwise backwards selection on model
summary(model_back) # Output model summary and check for variables to remove for final model
qn13 + qn19 + qn20 + qn23 + qn24 + qn25 + qn50 + qn56 + qn68 # Remove variables not included or signficiant in stepwise

## Final Model and AUC Score
model_final = glm(outcome~ qn13 + qn19 + qn20 + qn23 + qn24 + qn25 + qn50 + qn56 + qn68, data = train) # Perform logistic regression model on selected variables on test data
roc_train = roc(model_final$y, model_final$fitted.values, ci = T, plot = T) # Perform ROC test on test data
auc(roc_test) # Print AUC score

## Write Quantitative Selection Model Output to File
result1 = print(summary(model_back)) # Save result df to variable
result2 = print(summary(model_final)) # Save result df to variable
result3 = print(auc(roc_train)) # Save result df to variable
file = file("risk_yrbs_rf_factor_log_auc_results.txt") # Open result file in subproject repository
open(file, "a") # Open file and "a" to append
write("Backwards Stepwise Logistic Regression Model", file) # Insert space below title
write(" ", file) # Insert space below title
write("Final Model for Risk Score", file) # Insert space below title
write(" ", file) # Insert space below title
write("Training Model", file) # Insert space below title
capture.output(result3, file = file, append = TRUE) # write summary to file
write(" ", file) # Insert space below title
close(file) # Close file

### Step 5: Logistic Regression with Stepwise Selection for Final Model

## Develop Risk Score Variable

# Create new column based on conditions
test$hope <- 0 # Add new outcome column and set value to 0
test$hope <- 3.5*test$qn25 + 1.25*test$qn13 + test$qn19 + 1.5*test$qn20 + test$qn23 + test$qn50 + 0.75*test$qn68 + 0.75*test$qn56 + 0.5*test$qn24

## Final Model and AUC Score
model_test = glm(outcome~ hope, data = test) # Perform logistic regression model on selected variables on test data
roc_test = roc(model_test$y, model_test$fitted.values, ci = T, plot = T) # Perform ROC test on test data
auc(roc_test) # Print AUC score

## Write Quantitative Selection Model Output to File
result = print(auc(roc_test)) # Save result df to variable
file = file("risk_yrbs_rf_factor_log_auc_results.txt") # Open result file in subproject repository
open(file, "a") # Open file and "a" to append
write("Hope Score Validation", file) # Insert space below title
capture.output(result, file = file, append = TRUE) # write summary to file
write(" ", file) # Insert space below title
close(file) # Close file
>>>>>>> 321eaea894d29a3f212ee3e111b86695f46cf6db


# Di's attempt with keras, and correlation
library(keras)
library(tidyverse)
library(ash)
library(nullabor)
params <- read_csv("data/parameters.csv")
params0 <- read_csv("data/parameters_0.csv")
paramsb <- read_csv("data/parameters_b.csv")

simdata <- function(par, npixels) {
  x <- rnorm(n=par$n)
  y <- par$beta*x + rnorm(n=par$n, sd=par$sigma)
  #fit <- lm(y~x, data=data.frame(x, y))
  #newdata <- data.frame(x=seq(-4,4,0.1))
  #newdata$y <- predict(fit, newdata)
  i <- bin2(cbind(x, y), nbin=c(npixels, npixels))
  #i <- bin2(rbind(cbind(x, y), cbind(newdata$x, newdata$y)), nbin=c(npixels, npixels))
  i$nc <- ((i$nc - min(i$nc))/(max(i$nc) - min(i$nc)))*255
  return(i)
}

i1 <- simdata(paramsb[1,], npixels)
nimages <- 20000
nimages <- 40000
nimages <- 60000
nimages <- 80000
nimages <- 100000
nimages <- 120000
nimages <- 140000
nimages <- 160000

npixels <- 30
npixels <- 150

nulls <- array(dim=c(nimages, npixels, npixels))
for (i in 1:nimages) {
  i1 <- simdata(params0[i,], npixels)
  nulls[i,,] <- i1$nc
}

linear <- array(dim=c(nimages, npixels, npixels))
for (i in 1:nimages) {
  i1 <- simdata(paramsb[i,], npixels)
  linear[i,,] <- i1$nc
}

nulls <- array_reshape(nulls, c(nrow(nulls), npixels^2))
linear <- array_reshape(linear, c(nrow(linear), npixels^2))
train <- rbind(nulls, linear)
train_y <- to_categorical(c(rep(0, nimages), rep(1, nimages)), 2)

model <- keras_model_sequential()
model %>%
  layer_dense(units = 256, activation = 'relu', input_shape = c(npixels^2)) %>%
  layer_dropout(rate = 0.4) %>%
  layer_dense(units = 128, activation = 'relu') %>%
  layer_dropout(rate = 0.3) %>%
  layer_dense(units = 2, activation = 'softmax')
model %>% compile(
  loss = 'categorical_crossentropy',
  optimizer = optimizer_rmsprop(),
  metrics = c('accuracy')
)
history <- model %>% fit(
  train, train_y,
  epochs = 30, batch_size = 128,
  validation_split = 0.2
)
plot(history)

ntestimages <- 10000

nulls <- array(dim=c(ntestimages, npixels, npixels))
for (i in 1:ntestimages) {
  i1 <- simdata(params0[nimages+i,], npixels)
  nulls[i,,] <- i1$nc
}

linear <- array(dim=c(ntestimages, npixels, npixels))
for (i in 1:ntestimages) {
  i1 <- simdata(paramsb[nimages+i,], npixels)
  linear[i,,] <- i1$nc
}

nulls <- array_reshape(nulls, c(nrow(nulls), npixels^2))
linear <- array_reshape(linear, c(nrow(linear), npixels^2))
test <- rbind(nulls, linear)
test_y <- to_categorical(c(rep(0, ntestimages), rep(1, ntestimages)), 2)
model %>% evaluate(test, test_y)
model %>% predict_classes(test) -> test_yp
tb <- table(test_y[,2], test_yp)
(tb[1,1] + tb[2,2])/sum(tb)
tb[1,2]/sum(tb[1,])
tb[2,1]/sum(tb[2,])

training_size_sim <- tibble(
  nimages=c(20000, 40000, 60000, 80000, 100000, 120000, 140000, 160000),
  acc=c(0.9194, 0.9283, 0.93225, 0.92605, 0.92755, 0.92985, 0.92865, 0.9254),
  class0=c(0.031, 0.017, 0.0179, 0.0073, 0.0087, 0.0098, 0.005, 0.0059),
  class1=c(0.1302, 0.1264, 0.1176, 0.1406, 0.1362, 0.1305, 0.1377, 0.1433))

training_size_sim_50x50 <- tibble(
  nimages=c(20000, 40000, 60000, 80000, 100000, 120000, 140000, 160000),
  acc=c(0.8949, 0.9054, 0.9225, 0.9228, ),
  class0=c(0.0581, 0.0492, 0.023, 0.0164, ),
  class1=c(0.1521, 0.14, 0.132, 0.138, ))

# Read in Turk data
turk_trials <- read_csv("data/raw_data_turk2.csv")
# De-identify
#turk_trials_ip <- turk_trials %>% select(ip_address) %>%
#  mutate(ip_address_id = as.numeric(factor(ip_address)))
#turk_trials <- turk_trials %>% mutate(ip_address = as.numeric(factor(ip_address)))
#write_csv(turk_trials_ip, "data/turk2_ip_address.csv")
#write_csv(turk_trials, "data/raw_data_turk2.csv")

unique_pics <- turk_trials %>%
  select(pic_name, plot_location, sample_size, beta, sigma) %>%
  distinct() %>%
  separate(pic_name, c("name", "extra"), sep="\\.", remove=FALSE) %>%
  select(-extra) %>%
  mutate(name = str_sub(name, 6, str_length(name)))

#fl <- paste0("data/turk_data2/dat_", unique_pics$name[1], ".txt")
#d <- read_delim(fl, delim=" ")
#d %>% gather(.n, Y, -X) %>%
#  mutate(.n = as.numeric(.n)) %>%
#  ggplot(aes(X, Y)) +
#  geom_point(alpha=0.5) +
#  geom_smooth(method="lm", se=FALSE) +
#  facet_wrap(~.n, ncol=5)

# Check the turk results
# Convert to keras data form
#i <- bin2(cbind(d$X, as.vector(unlist(d[,turk_trials$plot_location[1]+1]))),
#          nbin=c(30, 30))
#i$nc <- ((i$nc - min(i$nc))/(max(i$nc) - min(i$nc)))*255
#turk_i <- array(dim=c(1, 30, 30))
#turk_i[1,,] <- i$nc
#turk_irow <- array_reshape(turk_i, c(nrow(turk_i), npixels^2))
#model %>% predict_classes(turk_irow)

# Predict them all
turk_i <- array(dim=c(nrow(unique_pics), npixels, npixels))
for (i in 1:nrow(unique_pics)) {
  fl <- paste0("data/turk_data2/dat_", unique_pics$name[i], ".txt")
  d <- read_delim(fl, delim=" ")
  img <- bin2(cbind(d$X, as.vector(unlist(d[,unique_pics$plot_location[i]+1]))),
            nbin=c(npixels, npixels))
  img$nc <- ((img$nc - min(img$nc))/(max(img$nc) - min(img$nc)))*255
  turk_i[i,,] <- img$nc
  cat(i, "\n")
}
turk_i <- array_reshape(turk_i, c(nrow(turk_i), npixels^2))

computer_predictions <- unique_pics
computer_predictions <- computer_predictions %>%
  mutate(c_p = model %>% predict_classes(turk_i))

# Human predictions
human_predictions <- turk_trials %>%
  group_by(pic_name) %>%
  summarise(x = length(response[response]),
            K = n(),
            prop = length(response[response])/n())
human_predictions$pval <- NA
for (i in 1:nrow(human_predictions)) {
  human_predictions$pval[i] <- pvisual(human_predictions$x[i], human_predictions$K[i])[2]
  cat(i, human_predictions$pval[i], "\n")
}
human_predictions <- human_predictions %>%
  mutate(h_p = ifelse(pval > 0.05, 0, 1))

predictions <- left_join(computer_predictions, human_predictions, by="pic_name")
predictions %>% count(c_p, h_p)
predictions <- predictions %>%
  mutate(effect = sqrt(sample_size)*abs(beta)/sigma)
#write_csv(predictions, path="data/predictions.csv")
# predictions <- read_csv("data/predictions.csv")

predictions_effect <- predictions %>%
  group_by(effect) %>%
  summarise(computer = sum(c_p)/n(),
            human = sum(h_p)/n()) %>%
  gather(predictor, p, -effect)

ggplot() +
  geom_line(data=ump, aes(x=effect, y=pow), colour="white", size=2) +
  geom_point(data=predictions_effect, aes(x=effect, y=p, colour=predictor), alpha=0.4) +
  geom_smooth(data=predictions_effect, aes(x=effect, y=p, colour=predictor), se=FALSE, span=0.9) +
  scale_color_brewer("", palette="Dark2")

predictions$alpha <- log(.05/0.95)
fit_c <- glm(c_p~offset(alpha)+effect-1, family="binomial", data=predictions)
newdata <- predictions %>% select(effect) %>% distinct() %>%
  mutate(alpha = log(.05/0.95))
pred_c <- predict(fit_c, newdata, type="response")
fit_h <- glm(h_p~offset(alpha)+effect-1, family="binomial", data=predictions)
pred_h <- predict(fit_h, newdata, type="response")
glm_predictions <- tibble(effect=newdata$effect, computer=pred_c, human=pred_h) %>%
  gather(predictor, p, -effect)

ggplot() +
  geom_line(data=ump, aes(x=effect, y=pow), colour="white", size=2) +
  geom_line(data=glm_predictions, aes(x=effect, y=p, colour=predictor), size=1) +
  scale_color_brewer("", palette="Dark2") +
  ylim(c(0,1)) +
  xlab("Effect") +
  ylab("Power")

predictions %>% filter(beta==0) %>%
  select(sample_size, beta, sigma, c_p, h_p)
table(predictions$h_p, predictions$c_p)
predictions %>% filter(h_p == 0) %>%
  select(name, plot_location, sample_size, beta, sigma, c_p, h_p) %>% arrange(beta) %>%
  print(n=50)
predictions %>% filter(c_p != h_p) %>%
  select(name, plot_location, sample_size, beta, sigma, c_p, h_p)
d <- read_delim("data/turk_data2/dat_turk2_100_350_12_1.txt", delim=" ")
ggplot(d, aes(x=X, y=`1`)) + geom_point(alpha=0.5)


# 비즈니스 관련 분석은 이 이정도에서 가능

a <-  1
a
b <- 2
b
c <- 3
c
d <- 3.5
d
a+b
a+b+c
4/b
5*b
var1 <-  c(1,2,5,7,8)
var1
var2 <- c(1:5)
var2
var3 <- seq(1,5)
var3
var4 <- seq(1, 10, by=2)
var4

var5 <- seq(1,10, by=3)
var5
var1
var1+2
var1+var2
var1

str1 <- "a"
str1
str2 <- "text"
str2
str3 <- "Hello World"
str3
str4 <- c("a","b","c")
str4
str5 <- c("Hello!", "World", "is", "good!")
str5
str1+2

x <- c(1, 2, 3)
x
mean(x)

max(x)
min(x)
str5
paste(str5, collapse = ",")
paste(str5, collapse = " ")

x_mean <- mean(x)
x_mean

str5_paste <- paste(str5, collapse = " ")
str5_paste

install.packages("ggplot2")
library(ggplot2)
x <- c("a", "a", "b", "c")
x
qplot(x)

qplot(data = mpg, x = hwy)
qplot(data = mpg, x = cty)
qplot(data = mpg, x = drv, y = hwy)
qplot(data = mpg, x = drv, y = hwy, geom = "line")
qplot(data = mpg, x = drv, y = hwy, geom = "boxplot")
qplot(data = mpg, x = drv, y = hwy, geom = "boxplot", colour = drv)
?qplot

test <- c(80,60,70,50,90)
test
mean(test)
test_mean <- mean(test)
test_mean

english　<- c(90, 80, 60, 70)
english

math <- c(50,60,100,20)
math

df_midterm <- data.frame(english, math)
df_midterm

class <- c(1,1,2,2)
class

df_midterm <- data.frame(english, math, class)
df_midterm

mean(df_midterm$english)
mean(df_midterm$math)

df_midterm <- data.frame(english=c(90,80,60,70),
                        math = c(50, 60, 100, 20),
                        class = c(1, 1, 2, 2))
df_midterm

df_fruit <- data.frame(제품 = c('사과','딸기','수박'),
                       가격 = c(1800, 1500, 3000),
                       판매량 = c(24, 38, 13))
df_fruit
mean(df_fruit$가격)
mean(df_fruit$판매량)

install.packages('readxl')
library(readxl)

df_exam <- read_excel("excel_exam.xlsx")
df_exam
df_exam <- read_excel("d:/easy_r/excel_exam.xlsx")
df_exam
mean(df_exam$english)
mean(df_exam$science)
df_exam_novar <- read_excel("excel_exam_novar.xlsx")
df_exam_novar
df_exam_novar <- read_excel("excel_exam_novar.xlsx", col_names = F)
df_exam_sheet <- read_excel("excel_exam_sheet.xlsx", sheet = 3)
df_exam_sheet

df_csv_exam <- read.csv("csv_exam.csv", stringsAsFactors = F)
df_csv_exam

df_midterm <- data.frame(english = c(90, 80, 60, 70),
                         math = c(50, 60, 100, 20),
                         class = c(1, 1, 2, 2))
df_midterm

write.csv(df_midterm, file = "df_midterm.csv")

saveRDS(df_midterm, file = "df_midterm.rds")
rm(df_midterm)
df_midterm
df_midterm <- readRDS("df_midterm.rds")
df_midterm

exam <- read.csv('csv_exam.csv')
head(exam)
head(exam, 10)
tail(exam)
tail(exam, 10)
View(exam)
dim(exam)[2]
str(exam)
summary(exam)

install.packages("ggplot2")
library(ggplot2)

mpg <- as.data.frame(ggplot2::mpg)
head(mpg)
tail(mpg)
View(mpg)
dim(mpg)
str(mpg)
?mpg
summary(mpg)

df_raw <- data.frame(var1 = c(1, 2, 1),
                     var2 = c(2, 3, 2))
df_raw

install.packages("dplyr")
library(dplyr)

df_new <- df_raw
df_new
df_new <- rename(df_new, v2 = var2)
df_new

mpg <- as.data.frame(ggplot2::mpg)
mpg_copy <- mpg

mpg_copy <- rename(mpg_copy, city = cty, highway = hwy)
mpg_copy
head(mpg_copy)

df <- data.frame(var1 = c(4, 3, 8),
                 var2 = c(2, 6, 1))
df

df$var_sum <- df$var1 + df$var2
df
df$var_mean <- (df$var1 + df$var2)/2
df

mpg$total <- (mpg$cty + mpg$hwy)/2
head(mpg)
mean(mpg$total)

summary(mpg$total)
hist(mpg$total)

mpg$test <- ifelse(mpg$total >= 20, "pass", "fail")
head(mpg, 20)
table(mpg$test)

library(ggplot2)
qplot(mpg$test)

mpg$grade <- ifelse(mpg$total >= 30, "A",
                    ifelse(mpg$total >= 20, "B", "C"))
head(mpg,10)
table(mpg$grade)
qplot(mpg$grade)

mpg$grade2 <- ifelse(mpg$total >= 30, "A",
                     ifelse(mpg$total >= 25, "B",
                            ifelse(mpg$total >= 20, "C", "D")))
head(mpg)

midwest <- as.data.frame(ggplot2::midwest)
str(midwest)

mw <- midwest

mw <- rename(mw, total = poptotal, asian = popasian)
head(mw)

mw$asianprop <- mw$asian / mw$total

hist(mw$asianprop)

mean(mw$asianprop)

mw$meanasian <- ifelse(mw$asianprop >= 0.0048 , "large", "small")

table(mw$meanasian)
qplot(mw$meanasian)

exam <- read.csv('csv_exam.csv')
exam
str(exam)

exam %>% filter(class != 1)
exam %>% filter(class != 3)
exam %>% filter(math > 5)
exam %>% filter(math < 50)
exam %>% filter(english >= 80)
exam %>% filter(english <= 80)

exam %>% filter(math >= 90 | english >= 90)
exam %>% filter(english <90 | science < 50)
exam %>% filter(class == 1 | class == 3 | class == 5)
exam %>% filter(class %in% c(1, 3, 5))

class1 <- exam %>% filter(class == 1)
class2 <- exam %>% filter(class == 2)

mean(class1$math)
mean(class2$math)

library(tidyverse)

mpg <- as.data.frame(ggplot2::mpg)
mpg_copy <- mpg

displ5 <- mpg_copy %>% filter(displ >= 5)
displ4 <- mpg_copy %>% filter(displ <= 4)

mean(displ5$hwy)
mean(displ4$hwy)

manaudi <- mpg_copy %>% filter(manufacturer == "audi")
mantoyota <- mpg_copy %>% filter(manufacturer == "toyota")

mean(manaudi$cty)
mean(mantoyota$cty)

manth <- mpg_copy %>% filter(manufacturer %in% c("chevrolet", "ford", "honda"))
mean(manth$hwy)

exam %>% select(math)
exam %>% select(english)
exam %>% select(class, math, english)

exam %>% select(-math)
exam %>% select(-math, -english)
exam %>% filter(class == 1) %>% select(english)

exam %>%
  filter(class == 1) %>%
  select(english)

exam %>%
  select(id, math) %>%
  head

exam %>%
  select(id, math) %>%
  head(10)

mpg_cl_ct <- mpg_copy %>% select(class, cty)

mpg_suv <- mpg_copy %>% filter(class == "suv") %>% select(cty)
mpg_compact <- mpg_copy %>% filter(class == "compact") %>% select(cty)
mean(mpg_suv$cty)
mean(mpg_compact$cty)
mean

library(tidyverse)
library(ggplot2)

exam %>% arrange(math)
exam %>% arragne(desc(math))
exam %>% arragne(class, math)

mpg <- as.data.frame(ggplot2::mpg)

head(mpg %>% filter(manufacturer == "audi") %>% arrange(hwy))

head(mpg)

exam %>%
  mutate(total = math + english + science) %>%
  head

exam %>%
  mutate(total = math + english + science,
         mean = (math + english + science)/3) %>%
  head

exam %>%
  mutate(test = ifelse(science >= 60, "pass", "fail")) %>%
  head

exam %>%
  mutate(total = math + english + science) %>%
  arrange(total) %>%
  head

mpg_c <- mpg
mpg_c <- mpg_c %>% mutate(total = hwy + cty)
mpg_c %>% head
mpg_c <- mpg_c %>% mutate(mean = total / 2)

mpg_c %>% arrange(mean) %>% head(3)

mpg %>% mutate(total = hwy + cty,
               mean = total / 2) %>%
  arrange(mean) %>%
  head(3)

exam %>%  summarise(mean_math = mean(math))

exam %>% group_by(class) %>%
  summarise(mean_math = mean(math))

exam %>% group_by(class) %>%
  summarise(mean_math = mean(math),
           sum_math = sum(math),
           median_math = median(math),
           n = n())

mpg %>%
  group_by(manufacturer, drv) %>%
  summarise(mean_cty = mean(cty)) %>%
  head(10)

mpg %>%
  group_by(manufacturer) %>%
  filter(class == "suv") %>%
  mutate(tot = (cty+hwy)/2) %>%
  summarise(mean_tot = mean(tot)) %>%
  arrange(desc(mean_tot)) %>%
  head(5)

mpg %>% group_by(class) %>%
  summarise(mean = mean(cty)) %>%
  arrange(desc(mean))

mpg %>% group_by(manufacturer) %>%
  summarise(mean = mean(hwy)) %>%
  arrange(desc(mean)) %>%
  head(3)

mpg %>% filter(class == "compact") %>%
  group_by(manufacturer) %>%
  summarise(n = n()) %>%
  arrange(desc(n))

test1 <- data.frame(id = c(1, 2, 3, 4, 5),
                    midterm = c(60, 80, 70, 90, 85))

test2 <- data.frame(id = c(1, 2, 3, 4, 5),
                    final = c(70, 83, 65, 95, 80))
test1
test2

total <- left_join(test1, test2, by = "id")
total

name <- data.frame(class = c(1, 2, 3, 4, 5),
                   teacher = c("kim", "lee", "park", "choi", "jung"))
name

exam_new <- left_join(exam, name, by = "class")
exam_new

group_a <- data.frame(id = c(1,2,3,4,5),
                      test = c(60, 80, 70, 90, 85))
group_b <- data.frame(id = c(6, 7, 8, 9, 10),
                      test = c(70, 83, 65, 95, 80))
group_a
group_b

group_all <- bind_rows(group_a, group_b)
group_all

head(mpg)

fuel <- data.frame(fl = c("c", "d", "e", "p", "r"),
                   price_f1 = c(2.35, 2.38, 2.11, 2.76, 2.22),
                   stringsAsFactors = F)
fuel
str(fuel)

left_join(mpg, fuel, by = "fl") %>%
  select(model, fl, price_f1) %>%
  head

midwest <- as.data.frame(ggplot2::midwest)

head(midwest)

midwest_c <- midwest

midwest_c <- midwest_c %>% mutate(prop = popadults / poptotal)

midwest_c %>% arrange(desc(prop)) %>%
  head(5)

midwest_c <- midwest_c %>%
  mutate(grade = ifelse(prop >= 0.4 ,"large",
                        ifelse(prop >= 0.3, "middle", "small")))
table(midwest_c$grade)

midwest %>%
  mutate(ratio_asian = (popasian / poptotal) * 100) %>%
  arrange(ratio_asian) %>%
  select(state, county, ratio_asian) %>%
  head(10)

df <- data.frame(sex = c("M", "F", NA, "M", "F"),
                 score = c(5, 4, 3, 4, NA))
df

is.na(df)
table(is.na(df))

table(is.na(df$sex))
table(is.na(df$score))


source("R/functions.r")
inittest <- init_landscape(c("+","0","-"), c(0.5,0.4,0.1))
mapping(50,50)
summary(inittest)

parmstest <- list(
del = 0.9,
b = 0.8,
c_ = 0.2,
m0 = 0.05,
g = 0.2,
r = 0.01,
f = 0.9,
d = 0.1,
protect = 0.5

  )

simtest <- ca(inittest, parmstest)


require(ggplot2)
require(GGally)
require(VGAM)

dat <- read.table("d:/tobit.csv", header=TRUE, sep=",", row.names="id")

summary(dat)

f <- function(x, var, bw = 15) {
  dnorm(x, mean = mean(var), sd(var)) * length(var)  * bw
}

p <- ggplot(dat, aes(x = apt, fill=prog))

p + stat_bin(binwidth=15) +
  stat_function(fun = f, size = 1,
    args = list(var = dat$apt))

p + stat_bin(binwidth = 1) + stat_function(fun = f, size = 1, args = list(var = dat$apt,
    bw = 1))

cor(dat[, c("read", "math", "apt")])

ggpairs(dat[, c("read", "math", "apt")])

------------------------------------------------------------------------------------------

#Below we run the tobit model, using the vglm function of the VGAM package.

summary(m <- vglm(apt ~ read + math + prog, tobit(Upper = 800), data = dat))

ctable <- coef(summary(m))
pvals <- 2 * pt(abs(ctable[, "z value"]), df.residual(m), lower.tail = FALSE)
cbind(ctable, pvals)

m2 <- vglm(apt ~ read + math, tobit(Upper = 800), data = dat)
(p <- pchisq(2 * (logLik(m) - logLik(m2)), df = 2, lower.tail = FALSE))

b <- coef(m)
se <- sqrt(diag(vcov(m)))

cbind(LL = b - qnorm(0.975) * se, UL = b + qnorm(0.975) * se)

dat$yhat <- fitted(m)[,1]
dat$rr <- resid(m, type = "response")
dat$rp <- resid(m, type = "pearson")[,1]
par(mfcol = c(2, 3))

with(dat, {
  plot(yhat, rr, main = "Fitted vs Residuals")
  qqnorm(rr)
  plot(yhat, rp, main = "Fitted vs Pearson Residuals")
  qqnorm(rp)
  plot(apt, rp, main = "Actual vs Pearson Residuals")
  plot(apt, yhat, main = "Actual vs Fitted")
})

(r <- with(dat, cor(yhat, apt)))
r^2


# 4. faza: Napredna analiza podatkov

#za leto 2019

library(ggalt)
library(cluster)
library(sp)
library(rgdal)
library(raster) # funkcija crop
library(rgeos)

 average_indeks1 <- average_indeks[-27,]
 graf_poskusni <- average_indeks1%>%ggplot()+
   geom_point(
   mapping = aes(x = x, y = x),
   size = 2
 ) + geom_label(
   mapping = aes(x = x, y = x, label = Država),
 ) + theme_classic()

 graf_poskusni

 dendrogram = average_indeks1[, -1] %>%
   dist() %>%
   hclust()

 plot(
   dendrogram,
   labels = average_indeks1$Država,
   ylab = "indeks",
   main = NULL
 )

 skupine.2 = dendrogram %>% cutree(k = 2) %>% as.ordered()

 library(dplyr)

 diagram.skupine = function(podatki, oznake, skupine, k) {
   podatki = podatki %>%
     bind_cols(skupine) %>%
     rename(skupina = ...3)

   d = podatki %>%
     ggplot(
       mapping = aes(
         x = x, y = x, color = skupina
       )
     ) +
     geom_point() + labs(x = "indeks", y = "indeks", title = sprintf("Razvrstitev držav v 2 skupini"))+
     geom_label(label = oznake, size = 2) +
     scale_color_hue() +
     theme_classic()

   for (i in 1:k) {
     d = d + geom_encircle(
       data = podatki %>%
         filter(skupina == i)
     )
   }
   d
 }
 k <- 2
diagram <- diagram.skupine(average_indeks1, average_indeks1$Država, skupine.2, k)
#
# average_indeks1 %>%
#   bind_cols(skupine.2) %>%
#   rename(skupina = ...3)
#
#
# rlang::last_error()

###Lin.regr. gledamo odvisnost bdppc od min.place
Gosp_zn_19 <- Gospodarske_značilnosti[190:216,]
g_12 <- ggplot(Gospodarske_značilnosti, aes(x=bdppc, y=vsota)) + geom_point() +
  labs(x = "BDPpc", y = "minimalna plača", title = sprintf("Linearna regresija"))
g_12 + geom_smooth(method="lm")
linearna_regresija <- g_12 + xlim(0,100000) + geom_smooth(method="lm", fullrange=TRUE)
linearna_regresija
#


# Data Wrangling in R
# 5.2 Missing and Special Values in R, Part 2

badmath <- c(1,2,3,4/0,0/0,NA)

is.na(badmath)

is.nan(badmath)

is.infinite(badmath)

is.finite(badmath)


#' Function that propagates measurement uncertainty through model results
#'
#' Function to propagate combined errors on \code{x} (= \code{Dsam}) and
#' \code{y} (= \code{Osam}) on the modeled X (= \code{D}) and Y
#' (= \code{d18Oc}) values by means of orthogonal projection of uncertainty
#' on \code{x} and \code{y} onto the model curve
#' @param x Vector of \code{x} values of input data
#' @param x_err Vector of uncertainties on \code{x} values
#' @param y Vector of \code{y} values of input data
#' @param y_err Vector of uncertainties on \code{y} values
#' @param X Vector of modeled \code{X} values on which the uncertainty is
#' to be projected
#' @param Y Matrix of modeled \code{X} and \code{Y} values
#' @param MC Number of Monte Carlo simulations to apply for error propagation
#' Default = 1000
#' @return A vector listing the standard deviations of propagated errors
#' propagated on all \code{X} values.
#' @examples
#' # Create dummy data for input
#' x <-  seq(1, 40, 1)
#' x_err <- rep(0.1, 40)
#' y <- sin((2 * pi * (seq(1, 40, 1) - 8 + 30 / 4)) / 30)
#' y_err <- rep(0.1, 40)
#' X <- seq(1.5, 39.5, 1)
#' Y <- cbind(seq(1, 39, 1), 0.9 * sin((2 * pi * (seq(1, 39, 1) - 9 +
#'     25 / 4)) / 25))
#' # Run function
#' result <- mc_err_orth(x, x_err, y, y_err, X, Y, 1000)
#' @export
mc_err_orth <- function(x,
    x_err,
    y,
    y_err,
    X,
    Y,
    MC = 1000){ # Function to propagate combined errors on x and y on the modeled X and Y values by means of orthogonal projection of x and y uncertainty on the model curve

    xmat <- matrix(rnorm(MC * length(x)), nrow = length(x)) * x_err + matrix(rep(x, MC), nrow = length(x)) # Create matrix of simulated X values
    ymat <- matrix(rnorm(MC * length(y)), nrow = length(y)) * y_err + matrix(rep(y, MC), nrow = length(y)) # Create matrix of simulated Y values
    Xarray <- sqrt( # create array of the length of vectors connecting each MC simulated x-y pair and each modeled X-Y pair.
        ((outer(xmat, X, FUN = "-") - mean(outer(xmat, X, FUN = "-"))) / sd(outer(xmat, X, FUN = "-"))) ^ 2 + # Square of the normalized difference between MC-simulated X values and modeled D
        ((outer(ymat, Y[, 2], FUN = "-") - mean(outer(ymat, Y[, 2], FUN = "-"))) / sd(outer(ymat, Y[, 2], FUN = "-"))) ^ 2 # Square of the normalized difference between MC-simulated y values and modeled Y values
    )
    posmat <- apply(Xarray, c(1,2), which.min) # For each MC-simulated x-y pair, find the position of the closest model value

    Xsimmat <- matrix(X[posmat], nrow = length(x)) # Find the X value that belongs to each position in posmat
    X_comb <- apply(Xsimmat, 1, mean) # calculate the mean value in X domain resulting from orthogonal projection of errors on X and Y from variability within the X values
    Ysimmat <- matrix(Y[posmat, 2], nrow = length(y)) # Find the Y value that belongs to each position in posmat
    Y_comb <- approx( # Interpolate modeled temperature values to positions along the record.
            x = X,
            y = Y[, 2],
            xout = X_comb,
            method = "linear",
            rule = 2
        )
    # Y_comb <- apply(Ysimmat, 1, mean) # calculate the mean value in Y domain resulting from orthogonal projection of errors on X and Y from variability within the X values
    X_err_comb <- apply(Xsimmat, 1, sd) # calculate the standard deviation in X domain resulting from orthogonal projection of errors on X and Y from variability within the X values
    Y_err_comb <- apply(Ysimmat, 1, sd) # calculate the standard deviation in Y domain resulting from orthogonal projection of errors on X and Y from variability within the X values
    result <- data.frame(
        X = X_comb,
        X_err = X_err_comb,
        Y = Y_comb$y,
        Y_err = Y_err_comb
    )
    return(result)
}


subroutine binsrt(x,y,rw,npd,ind,rind,tx,ty,ilst,nerror)
# Sort the data points into bins.
# Called by master.

implicit double precision(a-h,o-z)
dimension x(npd), y(npd), tx(npd), ty(npd)
integer rind(npd)
dimension ind(npd), ilst(npd)
dimension rw(4)

nerror = -1
kdiv   = 1+dble(npd)**0.25 # Round high.
xkdiv  = dble(kdiv)

# Dig out the corners of the rectangular window.
xmin = rw(1)
xmax = rw(2)
ymin = rw(3)
ymax = rw(4)

w = xmax-xmin
h = ymax-ymin

# Number of bins is to be approx. sqrt(npd); thus number of subdivisions
# on each side of rectangle is approx. npd**(1/4).
dw  = w/xkdiv
dh  = h/xkdiv

# The width of each bin is dw; the height is dh.  We shall move across
# the rectangle from left to right, then up, then back from right to
# left, then up, ....  Note that kx counts the divisions from the left,
# ky counts the divisions from the bottom; kx is incremented by ink, which
# is +/- 1 and switches sign when ky is incremented; ky is always
# incremented by 1.
kx   = 1
ky   = 1
ink  = 1
k    = 0
do i = 1,npd { ilst(i) = 0 } # Keeps a list of those points already added
while(ky<=kdiv) {            # to the new list.
        do i = 1,npd {
                if(ilst(i)==1) next  # The i-th point has already been added
                                     # to the new list.
                # If the i-th point is in the current bin, add it to the list.
                xt = x(i)
                yt = y(i)
                ix = 1+(xt-xmin)/dw
                if(ix>kdiv) ix = kdiv
                jy = 1+(yt-ymin)/dh
                if(jy>kdiv) jy = kdiv
                if(ix==kx&jy==ky) {
                        k = k+1
                        ind(i)  = k  # Index i is the pos'n. of (x,y) in the
                        rind(k) = i  # old list; k is its pos'n. in the new one.
                        tx(k)   = xt
                        ty(k)   = yt
                        ilst(i) = 1  # Cross the i-th point off the old list.
                }
        }
        # Move to the next bin.
        kc = kx+ink
        if((1<=kc)&(kc<=kdiv)) kx = kc
        else {
                ky  = ky+1
                ink = -ink
        }
}

# Check that all points from old list have been added to the new,
# with no spurious additions.
if(k!=npd) {
	nerror = 2
	return
}

# Copy the new sorted vector back on top of the old ones.
do i = 1,npd {
        x(i)   = tx(i)
        y(i)   = ty(i)
}

return
end


### "GLM, GAM, and RF for Mid to higher severity"

# setting
```{r}

########################## Data setting
### Setting
rm(list=ls(all=TRUE))

library(data.table)
library(dplyr)
library(ggplot2)
library(car)
library(psych)
library(pROC)
library(mgcv)
library(epitools)
library(tableone)
library(caret)
library(tictoc)
library(Boruta)

library(doParallel)
detectCores(all.tests = FALSE, logical = TRUE)
cl <- makePSOCKcluster(27)
registerDoParallel(cl)

setwd(".")
set.seed(1234)

######################### Input data
Data <- fread("Data_demo.csv", encoding = "UTF-8" )
Data$V1 <- NULL

colnames(Data)
dim(Data)

Data[, table(TrainTest), ]

Data_train <- Data[TrainTest == "Train", , ] #*eligible
Data_train <- data.frame(Data_train)

Data_test <- Data[TrainTest == "Test", , ] #*eligible

######################## Prediction settings
# CV methods
CV_method <- "cv"
CV_number <- 5
Repeated_number <- 1
Tune_number <- 1

# formula
Form_temp <- formula(
	SeverityHigherMid ~
	offset(LogPopulation100000) +
	Mean_income_city_2015 +
	Green_area_percent +
	Age_median_city +
	Population_over_65_100000 +
	SexRatioF +

	RainySeason +
	DifDateRain +
	holiday_flag +
	Hour +
	Month +

	precip1Hour +
	windSpeed_ms +
	DownwardSolarRadiation_kwm2 +
	relativeHumidity +
	temperature +
	temperature_past1d_max_diff +
	temperature_past1d_mean_diff +
	temperature_past1d_min_diff
)

Model_vif <- glm(
	family = "poisson",
	Form_temp,
	data = Data_train
	)
summary(Model_vif)
vif(Model_vif)

```

# GLM with WBGT only
```{r}
glm_uni <- glm(
	family = "poisson",
	SeverityHigherMid ~
	offset(LogPopulation100000) +
	WBGT,
	data = Data_train
	)
summary(glm_uni)

saveRDS(glm_uni, "glm_uni.rds")

```

# GLM
```{r}

##################################################################
###   GLM
##################################################################

modelLookup("glm")

### caretが指定する
Size_n <- 18

Seeds_fix <- vector(mode = "list", length = CV_number * Repeated_number + 1)
for(i in 1:(CV_number * Repeated_number)) Seeds_fix[[i]] <- sample.int(n = 10000, size = Size_n )

Seeds_fix[[(CV_number * Repeated_number + 1)]] <- sample.int(10000, 1)
Seeds_fix

# construct rfeControl object
rfe_control = rfeControl(
	functions = caretFuncs,
	allowParallel = TRUE,
	method = CV_method,
    number = CV_number,
	returnResamp = "final",
	seeds = Seeds_fix
	)

# construct trainControl object for train method
fit_control = trainControl(
	allowParallel = TRUE,
	method = CV_method,
	number = CV_number,
	seeds = Seeds_fix
	)

# GLM
tic()
GLM_temp <- rfe(
	form = Form_temp,
	data = Data_train,
    method = "glm",
	family = "poisson",

	trControl = fit_control,
	metric = "RMSE",
	preProcess = c("center", "scale"),
	tuneLength = 10,

    sizes = 1:19, #ncol(Data),
    rfeControl = rfe_control
	)
summary(GLM_temp)
GLM_temp
toc()

GLM_temp$optVariables

saveRDS(GLM_temp, "GLM_temp.rds")

```

# GAM
```{r}

##################################################################
###   GAM
##################################################################

modelLookup("gamSpline")

### caretが指定する
Size_n <- 18

Seeds_fix <- vector(mode = "list", length = CV_number * Repeated_number + 1)
for(i in 1:(CV_number * Repeated_number)) Seeds_fix[[i]] <- sample.int(n = 10000, size = Size_n )

Seeds_fix[[(CV_number * Repeated_number + 1)]] <- sample.int(10000, 1)
Seeds_fix

# construct rfeControl object
rfe_control = rfeControl(
	functions = caretFuncs,
	allowParallel = TRUE,
	method = CV_method,
    number = CV_number,
	returnResamp = "final",
	seeds = Seeds_fix
	)

# construct trainControl object for train method
fit_control = trainControl(
	allowParallel = TRUE,
	method = CV_method,
	number = CV_number,
	seeds = Seeds_fix
	)

# gamSpline
tic()
gamSpline_temp <- rfe(
	form = Form_temp,
	data = Data_train,
    method = "gamSpline",
	family = "poisson",

	trControl = fit_control,
	metric = "RMSE",
	preProcess = c("center", "scale"),
	tuneLength = 10,

    sizes = 1:19, #ncol(Data),
    rfeControl = rfe_control
	)
summary(gamSpline_temp)
gamSpline_temp
toc()

gamSpline_temp$optVariables

saveRDS(gamSpline_temp, "gamSpline_temp.rds")

```

# RF
```{r}

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

# formula
Form_temp <- formula(
	SeverityHigherMid ~
	Population100000 +
	Mean_income_city_2015 +
	Green_area_percent +
	Age_median_city +
	Population_over_65_100000 +
	SexRatioF +

	RainySeason +
	DifDateRain +
	holiday_flag +
	Hour +
	Month +

	precip1Hour +
	windSpeed_ms +
	DownwardSolarRadiation_kwm2 +
	relativeHumidity +
	temperature +
	temperature_past1d_max_diff +
	temperature_past1d_mean_diff +
	temperature_past1d_min_diff
)

##################################################################
###   Random Forest
##################################################################

### caretが指定する
Size_n <- 19
Seeds_fix <- vector(mode = "list", length = CV_number * Repeated_number + 1)
for(i in 1:(CV_number * Repeated_number)) Seeds_fix[[i]] <- sample.int(n = 10000, size = Size_n )
Seeds_fix[[(CV_number * Repeated_number + 1)]] <- sample.int(10000, 1)
Seeds_fix

# construct rfeControl object
rfe_control = rfeControl(
	functions = rfFuncs,
	allowParallel = TRUE,
	method = CV_method,
    number = CV_number,
	returnResamp = "final",
	seeds = Seeds_fix,
	)

# construct trainControl object for train method
fit_control = trainControl(
	allowParallel = TRUE,
	method = CV_method,
	number = CV_number,
	seeds = Seeds_fix
	)

# RF
tic()
# get results
RF_temp <- rfe(
	form = Form_temp,
	data = Data_train,

	trControl = fit_control,
	metric = "RMSE",
	preProcess = c("center", "scale"),
	tuneLength = 10,

    sizes = 1:20, #ncol(Data),
    rfeControl = rfe_control
	)
summary(RF_temp)
RF_temp
toc()

saveRDS(RF_temp, "RF_temp.rds")

```

# info
```{r}
sessionInfo()

```


# Read HadDTR temperature data
# see https://stackoverflow.com/questions/24115110/importing-sea-surface-temperature-text-files-in-ascii-format-into-rrequire(raster)
require(raster)
require(abind)

# Read in sst climatology (guide for interpolation)
load('temp/oisst0.5deg_1986_2005.rdata') # tempsarray at 0.5x0.5 1986-2005
	sstclim <- tempsarray
load('temp/oisst1986_1990.rdata') # tempsarray at 0.25x0.25
	sstclim025 <- tempsarray

# Read in HadDTR
f <- 'data_dl/hatdtr/monthly_climatology.txt'
d <- readLines(f)
d <- split(d, rep(1:12, each=30)) # 12 months of 30 lines each
d <- lapply(d, function(x) read.fwf(textConnection(x), rep(8, 72), skip=1, stringsAsFactors=FALSE, na.strings=c(' -99.99 ', ' -99.99'))) # 72 fields of 8 chars each
d <- lapply(d, function(x) sapply(x, as.numeric))
da <- array(unlist(d), dim = c(nrow(d[[1]]), ncol(d[[1]]), length(d))) # to array

# Rotate so 0-360 columns and rows 90 to -90 (like cmip5)
da2 <- abind(da[,37:72,], da[,1:36,], along=2)

# Create raster brick
dtrb <- brick(da2)
names(dtrb) <- month.abb # a constant in R
extent(dtrb) <- c(0, 360, -90, 90)
proj4string(dtrb) <- '+proj=longlat +datum=WGS84'

# examine
dtrb
plot(dtrb[[1]])
plot(dtrb)

# interpolate to 0.5x0.5 ° (no longer used)
	# create new grid
	ngrd <- expand.grid(lat=as.numeric(rownames(sstclim)), lon=as.numeric(colnames(sstclim)))
	ngrd.sp <- ngrd[,c('lon', 'lat')]
	coordinates(ngrd.sp) <- ~lon + lat
	proj4string(ngrd.sp) <- '+proj=longlat +datum=WGS84'

	# interpolate: raster query approach with points
	newvalss <- extract(dtrb, ngrd.sp, method='bilinear')
	dtr05rast <- rasterFromXYZ(cbind(ngrd[,c('lon', 'lat')], newvalss))
	proj4string(dtr05rast) <- '+proj=longlat +datum=WGS84'

	# examine
	dtr05rast
	plot(dtr05rast)

	# make array
	dtr <- as.array(dtr05rast)
	dimnames(dtr) <- list(lat=as.numeric(rownames(sstclim)), lon=as.numeric(colnames(sstclim)), mon=month.abb)

	# write out array
	save(dtr, file='temp/dtrclimatology.rdata')

# interpolate to 0.25x0.25° (OISST)
	# create new grid
	ngrd2 <- expand.grid(lat=as.numeric(rownames(sstclim025)), lon=as.numeric(colnames(sstclim025)))
	ngrd2.sp <- ngrd2[,c('lon', 'lat')]
	coordinates(ngrd2.sp) <- ~lon + lat
	proj4string(ngrd2.sp) <- '+proj=longlat +datum=WGS84'

	# interpolate: raster query approach with points
	newvalss2 <- extract(dtrb, ngrd2.sp, method='bilinear')
	dtr025rast <- rasterFromXYZ(cbind(ngrd2[,c('lon', 'lat')], newvalss2))
	proj4string(dtr025rast) <- '+proj=longlat +datum=WGS84'

	# examine
	dtr025rast
	plot(dtr025rast[[1]])
	plot(dtr025rast)

	# make array
	dtr025 <- as.array(dtr025rast)
	dimnames(dtr025) <- list(lat=as.numeric(rownames(sstclim025)), lon=as.numeric(colnames(sstclim025)), mon=month.abb)

	# write out array
	save(dtr025, file='temp/dtrclimatology0.25.rdata')

# interpolate to 1.25x1.25° (CMIP5 tos)
	# create new grid
	ngrd3 <- expand.grid(lat=seq(-89.375, 89.375, by=1.25), lon=seq(0.625, 359.375, by=1.25))
	ngrd3.sp <- ngrd3[,c('lon', 'lat')]
	coordinates(ngrd3.sp) <- ~lon + lat
	proj4string(ngrd3.sp) <- '+proj=longlat +datum=WGS84'

	# interpolate: raster query approach with points
	newvalss3 <- extract(dtrb, ngrd3.sp, method='bilinear')
	dtr125rast <- rasterFromXYZ(cbind(ngrd3[,c('lon', 'lat')], newvalss3))
	proj4string(dtr125rast) <- '+proj=longlat +datum=WGS84'

	# examine
	dtr125rast
	plot(dtr125rast[[1]])
	plot(dtr125rast)

	# make array
	dtr125 <- as.array(dtr125rast)
	dimnames(dtr125) <- list(lat=seq(-89.375, 89.375, by=1.25), lon=seq(0.625, 359.375, by=1.25), mon=month.abb)

	# write out array
	save(dtr125, file='temp/dtrclimatology1.25.rdata')


#' @export
MinEuclidean1xn <- function(a,b){
  for(i in 1:length(b)){
    b[i] <- DEuclidean1x1(a,b[i])
  }
  return(which.min(b))
}

#' @export
MinEuclidean1x1 <- function(a,b){
  for(i in 1:length(b)){
    b[i] <- DEuclidean1x1(a,b[i])
    print(b[i])
  }
  return(which.min(b))
}

#' @export
DEuclidean1x1 <- function(a,b){
  return(sqrt(sum((a - b)^2)))
}

#' @export
DEuclidean1xn <- function(a,b){
  Dist<-0.0
  s<-0.0
  for(i in 1:length(b)){
    s <- s + (a - b[i])^2
  }
  return(sqrt(s))
}