# load packages --------------------
install.packages("psych")
install.packages("DMwR")
library(psych)
library(dplyr)
library(DMwR)
library(zoo)

# 1. load data ---------------------
# 1-1. weather
weather <- read.csv("C:/Users/huiyeon/Desktop/Dacon/11회 data 과거 인천 기상예측/hourly_weather.csv")
colnames(weather) <- c("place", "Time", "Temp", "rain", "wind", "hum", "snow", "condition", "cloud")
#지점, 일시, 기온, 강수량, 풍속, 습도, 적설, 날씨, 전운량

# 1-2. Elctric demand
train <- read.csv("C:/Users/huiyeon/Desktop/Dacon/11회 data/train.csv")  # (16909, 1301)
test <- read.csv("C:/Users/huiyeon/Desktop/Dacon/11회 data/test.csv")  # (8760, 201)

# 2. EDA ---------------------------
# 2-1. weather
summary(weather)
describe(weather)
weather <- weather[, c("Time", "Temp", "hum")]

# 2-2. Electirc demand
# ex) X692
summary(train$X692)
describe(train$X692)

# 3. KNN-Imputation ----------------
# 3-1. weather
# Temp, hum
sum(is.na(weather))  # 38
k <- round(sqrt(nrow(weather)))  # 적정 K값
weather_pre <- knnImputation(weather, k=k)
sum(is.na(weather_pre))  # 0

# 3-2. Electric demand
"""
# ERROR
which(is.na(train$X692)== F, arr.ind = TRUE)[1]  # 13646
which(is.na(train$X1272)== F, arr.ind = TRUE)[1]  # 13646
which(is.na(train$X553)== F, arr.ind = TRUE)[1]  # 13646
# ex) X692, X1272
f1 <- which(is.na(train$X692)== F, arr.ind = TRUE)[1]  # first not null
f2 <- which(is.na(train$X1272)== F, arr.ind = TRUE)[1]  # first not null
f3 <- which(is.na(train$X553)== F, arr.ind = TRUE)[1]  # first not null

a <- data.frame(train$X692[f1:length(train$X692)],
                train$X1272[f2:length(train$X1272)],train$X553[f3:length(train$X553)])
colnames(a) <- c('X692', 'X1272', 'X553')  # 열 이름 지정
head(a)

sum(is.na(a))  # 622
k <- round(sqrt(nrow(a)))  # 적정 K값
a_pre <- knnImputation(a)
"""
# 4. To csv ------------------------
write.csv(weather_pre, "C:/Users/huiyeon/Desktop/Dacon/weather_knn.csv")


R version 3.2.2 (2015-08-14) -- "Fire Safety"
Copyright (C) 2015 The R Foundation for Statistical Computing
Platform: x86_64-w64-mingw32/x64 (64-bit)

R is free software and comes with ABSOLUTELY NO WARRANTY.
You are welcome to redistribute it under certain conditions.
Type 'license()' or 'licence()' for distribution details.

R is a collaborative project with many contributors.
Type 'contributors()' for more information and
'citation()' on how to cite R or R packages in publications.

Type 'demo()' for some demos, 'help()' for on-line help, or
'help.start()' for an HTML browser interface to help.
Type 'q()' to quit R.

[Workspace loaded from ~/.RData]

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

 ArrivalRate <- 3/20

 ArrivalRate

 ServiceRate <- c(1/8, 1/3)

 ServiceRate

 p <- 0.75

 TransitionMatrix <- matrix(c(1,   ServiceRate[1],     0,
                               1,   -ArrivalRate,       (1-p)*ArrivalRate,
                               1,   ServiceRate[2],     -ServiceRate[2]), byrow=T, ncol=3)

 TransitionMatrix

 B <- c(1, 0, 0)

 P <- solve(t(A), B)

 P

 Resolution <- sum(P * c(1, 0, 1))

 Resolution

 set.seed(1234)

 option.1 <- function(t) {
      car <- create_trajectory() %>%
          seize("pump", amount=1) %>%
          timeout(function() rexp(1, ServiceRate[1])) %>%
          release("pump", amount=1)

      motorcycle <- create_trajectory() %>%
          seize("pump", amount=1) %>%
          timeout(function() rexp(1, ServiceRate[2])) %>%
          release("pump", amount=1)

      simmer() %>%
          add_resource("pump", capacity=1, queue_size=0) %>%
          add_generator("car", car, function() rexp(1, p*ArrivalRate)) %>%
          add_generator("motorcycle", motorcycle, function() rexp(1, (1-p)*ArrivalRate)) %>%
          run(until=t)
  }

 option.2 <- function(t) {
      vehicle <- create_trajectory() %>%
          seize("pump", amount=1) %>%
          branch(function() sample(c(1, 2), 1, prob=c(p, 1-p)), merge=c(T, T),
                 create_trajectory("car") %>%
                     timeout(function() rexp(1, ServiceRate[1])),
                 create_trajectory("motorcycle") %>%
                     timeout(function() rexp(1, ServiceRate[2]))) %>%
          release("pump", amount=1)

      simmer() %>%
          add_resource("pump", capacity=1, queue_size=0) %>%
          add_generator("vehicle", vehicle, function() rexp(1, ArrivalRate)) %>%
          run(until=t)
  }

 option.3 <- function(t) {
      vehicle <- create_trajectory() %>%
          seize("pump", amount=1) %>%
          timeout(function() {
              if (runif(1) < p) rexp(1, ServiceRate[1])
              else rexp(1, ServiceRate[2])
          }) %>%
          release("pump", amount=1)

      simmer() %>%
          add_resource("pump", capacity=1, queue_size=0) %>%
          add_generator("vehicle", vehicle, function() rexp(1, ArrivalRate)) %>%
          run(until=t)
  }

 gas.station <- option.3(5000)

 graph <- plot_resource_usage(gas.station, "pump", items="system")

 graph + geom_hline(yintercept = Resolution)

Chapter 08/4Continuous Time Markov Chains - Vehicle Service at Gas Station.r


# fwhm.R
# Full width half maximum and maximum at full width.
# The arguments x and y comes from the output
# of the density() function, i.e, x = density()$x, y = density()$y

fwhm <- function(x,y){

  xy <- data.frame(x = x,y = y)
  xmax <- xy$x[xy$y==max(xy$y)][1] # thakes just one max if there were 2
  x1 <- xy$x[xy$x < xmax][which.min(abs(xy$y[xy$x < xmax] - max(xy$y)/2))]
  x2 <- xy$x[xy$x > xmax][which.min(abs(xy$y[xy$x > xmax] - max(xy$y)/2))]
  fwhm <- x2 - x1
  list(fwhm = fwhm,peak = xmax)
}


rm(list=ls())

library(dplyr)
library(tidyr)
library(ggplot2)
library(ggpubr)

BFofAvg <- function(df,numor,denoms){

  # Create a new dataset for new BF values & add a new empty column to populate later
  new <- subset(df, select = c('Locus'))
  new$newestAvgBF <- vector(mode="numeric",length=length(new$Locus))

  # for locus in dataset
  for (i in 1:nrow(new)){

    # Vector of denoms for this i
    idenoms <- denoms[i,c(2,length(names(denoms)))]

    # Maximum of alternate margLH
    a <- max(idenoms)

    # Calculate average across alternate constraints - sum does a sigma sum across all values in the list passed to it
    avg <- a+log(sum(exp(idenoms-a)))-log(length(idenoms))

    # Calculate bayes factor - 2ln(BF)
    new[i,2] <- 2*(numor[i,2] - avg)
    }

  return(new)
}

# set dataset

#dataset <- "Streicher"
#dataset <- "Singhal"
#dataset <- "Reeder"
dataset <- "Burbrink"
#dataset <- "SinghalOG"

setwd(paste("/Users/ChatNoir/Projects/Squam/Graphs/",dataset, sep=''))

# Read in data

## Read in data tables, drop any rows that have all NAs
mLBF <- read.table(paste("/Users/ChatNoir/Projects/Squam/scripts/Graphing/DataFiles/",dataset,"MargLikeSummaryNA.txt",sep=""),
                   header=TRUE) %>% drop_na()
mLGL <- read.table(paste("/Users/ChatNoir/Projects/Squam/scripts/Graphing/DataFiles/",dataset,"MaxLikeSummaryNA.txt",sep=""),
                     header=TRUE) %>% drop_na()
#mLGL <- read.table(paste("/Users/ChatNoir/Projects/Squam/scripts/Graphing/DataFiles/",dataset,"MaxLikeSummary.txt",sep=""),
#                   header=TRUE) %>% drop_na()

## Number of overlapping
length(intersect(mLBF$Locus,mLGL$Locus))

# Remove any other from the larger dataset
mLBF <- mLBF[mLBF$Locus %in% intersect(mLBF$Locus,mLGL$Locus),]

# Bayes factors

# K = lnBF(m1,m2) = ln(m1) - ln(m2)
# 2ln(BF) = 2ln(e^K) = 2*K = 2(ln(m1) - ln(m2))

mL <- mLBF

## Calculate BF and put in new columns
mL$TvS <- 2*(mL$ToxPoly-mL$Sclero)
mL$AIvSA <- 2*(mL$ToxAngIg-mL$ToxSnAng)
mL$AIvSI <- 2*(mL$ToxAngIg-mL$ToxSnIg)
mL$SAvSI <- 2*(mL$ToxSnAng-mL$ToxSnIg)

# Select numorator and denominators to average over
# Get BF values
# Add new values to main dataframe
n1 <- mL[,(names(mL) %in% c("ToxAngIg","Locus"))]
d1 <- mL[,(names(mL) %in% c("ToxSnAng", "ToxSnIg","Locus"))]
x1 <- BFofAvg(mL,n1,d1)
mL<-left_join(mL,x1,by='Locus') %>% rename(AIvAvg=newestAvgBF)

# Select numorator and denominators to average over
# Get BF values
# Add new values to main dataframe
n2 <- mL[,(names(mL) %in% c("ToxSnAng","Locus"))]
d2 <- mL[,(names(mL) %in% c("ToxAngIg", "ToxSnIg","Locus"))]
x2 <- BFofAvg(mL,n2,d2)
mL<-left_join(mL,x2,by='Locus') %>% rename(SAvAvg=newestAvgBF)

# Select numorator and denominators to average over
# Get BF values
# Add new values to main dataframe
n3 <- mL[,(names(mL) %in% c("ToxSnIg","Locus"))]
d3 <- mL[,(names(mL) %in% c("ToxSnAng", "ToxAngIg","Locus"))]
x3 <- BFofAvg(mL,n3,d3)
mL<-left_join(mL,x3,by='Locus') %>% rename(SIvAvg=newestAvgBF)

## Switch back into mLBF and clear mL variable to use with dGLS

mLBF <- mL

rm(mL)

# Different in gene log likelihood

# dGLS = LH1 - LH2

mL <- mLGL

## Calculate dGLS and put in new columns
mL$TvS <- (mL$ToxPoly-mL$Sclero)
mL$AIvSA <- (mL$ToxAngIg-mL$ToxSnAng)
mL$AIvSI <- (mL$ToxAngIg-mL$ToxSnIg)
mL$SAvSI <- (mL$ToxSnAng-mL$ToxSnIg)
## Averages
mL$AIvAvg <- (mL$ToxAngIg-((mL$ToxSnIg+mL$ToxSnAng)/2))
mL$SAvAvg <- (mL$ToxSnAng-((mL$ToxAngIg+mL$ToxSnIg)/2))
mL$SIvAvg <- (mL$ToxSnIg-((mL$ToxAngIg+mL$ToxSnAng)/2))

## Switch back into mLBF and clear mL variable to use with dGLS

mLGL <- mL

rm(mL)

# If you want to save..

save(mLGL, mLBF, file=paste("Calcs_",dataset,".RData",sep=""))
#save(mLBF, file=paste("Calcs_",dataset,"_BFonly.RData",sep=""))


#' tilde_beta
#'
#' transformed coefficient $\tilde{\beta}$
#'
#' @param v_beta  coefficients for scop
#' @param k1 dimension of the first covariate
#'
#'
#' @return transformed coefficient $\tilde{\beta}$
#'
#' @examples
#' \dontrun{
#' k1 <- 4; ktau <- 4; m1 <- 4; mtau <- 4; y <- rnorm(200)
#' n1 <- f_n1(1:200, k1, m1); beta <- rnorm(prod(ktau + mtau, k1 + m1))
#' til_beta <- tilde_beta(beta, ktau + mtau, k1 + m1)
#' }

tilde_beta <- function(v_beta, k1) {
    v_idx <- seq_len(k1)
    v_beta[-v_idx] <- exp(v_beta[-v_idx])
    #cap the maximum values
    v_beta[which(v_beta == Inf)] <- 1e8
    return(v_beta)
}

#' og_beta
#'
#' transformed coefficient from $\tilde{\beta}$ to $\beta$
#'
#' @param til_beta  coefficients for scop
#' @param ktau dimension of the taus
#' @param k1 dimension of the first covariate
#'
#'
#' @return transformed coefficient $\beta$
#'
#' @examples
#' \dontrun{
#' k1 <- 4; ktau <- 4; m1 <- 4; mtau <- 4; y <- rnorm(200)
#' n1 <- f_n1(1:200, k1, m1); beta <- rnorm(prod(ktau + mtau, k1 + m1))
#' til_beta <- tilde_beta(beta, k1 + m1)
#' og_beta(til_beta, ktau + mtau, k1 + m1)
#' }

og_beta <- function(til_beta, ktau, k1) {
    #Index of til_betas
    v_idx <- seq_len(k1)
    v_idx <- seq_len(k1 * ktau)[-v_idx]
    #deal with NAs
    v_naidx <- intersect(v_idx, which(til_beta < 0))
    til_beta[v_naidx] <- 0
    #Transform
    til_beta[v_idx] <- log(til_beta[v_idx])
    # Deal with 0s
    til_beta[which(til_beta == -Inf)] <- -1e5
    return(til_beta)
}


# Analysis of differences between one barometer and many others in its neighbourhood.
# This one uses the data from 04 to make a first estimate of the barometer error.

# This produces the results variable.
# To speed this up, set compute(make.plot = FALSE) in the sourced file.
source('./drifts/analysis_04.r')

list.quant <- lapply(results, function(df) {
  if (is.null(df)) return(data.table::data.table())
  df.Q <- df[, .(Q.5 = quantile(PRESSURE_DIFF, 0.5), N.GROUP = .N), by = TIMESTAMP_UTC]
  df.Q <- df.Q[N.GROUP >= 10, ]
  wiskers <- boxplot.stats(df.Q[, Q.5])$stats[c(1, 5)]
  df.Q[, Q.5.centered := Q.5 - mean(wiskers)]
  df.Q[, FILE := basename(attr(df, 'logger.name'))]
  df.Q[, N := .N]
  df.Q[, IQR := IQR(Q.5)]
  df.Q[, WISK := wiskers[2L] - wiskers[1L]]
  df.Q[, PERC.95 := quantile(Q.5, 0.975) - quantile(Q.5, 0.025)]
  df.Q[, SD := sd(Q.5)]
  df.Q
})

local(with(list.quant[['barometer/BAOL016X_77551.csv']], {
  print(ggplot2::ggplot(mapping = ggplot2::aes(x = TIMESTAMP_UTC)) +
          ggplot2::geom_line(mapping = ggplot2::aes(y = Q.5), col = 'red', alpha = 0.5) +
          ggplot2::theme_light() +
          ggplot2::theme(axis.text.y = ggplot2::element_text(angle = 90, hjust = 0.5)))
  plot(x = TIMESTAMP_UTC, y = Q.5, pch = '.')

  par(mfrow = c(1, 2))
  on.exit(par(mfrow = c(1, 1)))
  hist(Q.5, breaks = 50, main = '')
  boxplot(Q.5)
  boxplot.stats(Q.5)$stats
}))

df.quant <- data.table::rbindlist(list.quant) # 424332 observations, 414692 with df.quant[N.GROUP >= 10, ]
df.quant[, LABEL := sprintf('%s (#%i) [%.2f WISK]', FILE, N, WISK)]
df.quant <- df.quant[order(WISK, LABEL), ]
df.quant[, LABEL := factor(LABEL, levels = unique(LABEL))]

ggplot2::ggplot(data = df.quant, mapping = ggplot2::aes(y = Q.5.centered, x = LABEL)) +
  ggplot2::geom_boxplot() +
  ggplot2::coord_flip(ylim = c(-25, 25)) +
  ggplot2::ggtitle(label = 'Centered distrbiution of median curve (red) from analysis 04',
                   subtitle = NULL) +
  ggplot2::xlab(NULL) +
  ggplot2::theme_light()

ggplot2::ggsave('./drifts/analysis_10/baro_median_errors_uhd-1.png', width = 2160/96, height = 3840/96, dpi = 96)

write.csv(unique(df.quant[,.(FILE, N, IQR, WISK, PERC.95, SD)]), file = './drifts/analysis_10/baro_median_errors.csv', row.names = FALSE)


setwd('/home/lucas/Dev/git/mlclass-private/01_Preprocessing')
diaInfo <- read.csv(file = 'diabetes_dataset.csv')
diaAva <- read.csv(file = 'diabetes_app.csv')
diaMean <- c()
diaNonMean <- c()
maxValue <- c()
minValue <- c()
sdDia <- c()
sdNonDia <- c()
for(categ in 1:8){
  diaMean[categ] <- c(mean(diaInfo[which(diaInfo$Outcome == 1),categ],na.rm=TRUE))
  diaNonMean[categ] <- c(mean(diaInfo[which(diaInfo$Outcome == 0),categ],na.rm=TRUE))
  maxValue[categ] = max(diaInfo[,categ],na.rm = TRUE)
  minValue[categ] = min(diaInfo[,categ],na.rm = TRUE)
  sdDia[categ] <- c(sd(diaInfo[which(diaInfo$Outcome == 1),categ],na.rm=TRUE))
  sdNonDia[categ] <- c(sd(diaInfo[which(diaInfo$Outcome == 0),categ],na.rm=TRUE))
}
weight <- c()
weight[1]=2
weight[2]=3
weight[3]=0.5
weight[4]=1
weight[5]=1
weight[6]=2
weight[7]=0.5
weight[8]=3

for(i in 1:572){
  actual <- diaInfo[i,]
  for(categ in 1:8){
    # if(xor(!is.na(actual[4]),!is.na(actual[6]))){
    #   if(is.na(actual[4])){
    #     diaInfo[i,4] = actual[6]*0.351
    #   }else{
    #     diaInfo[i,6] = actual[4]*1/0.351
    #   }
    #
    # }
    if(is.na(actual[categ])|| is.null(actual[categ]))
    {
      randomizer <- runif(1,min=0.2,max=1)
      if(actual[9]==1) {
        # actual[categ] = diaMean[categ] + sdDia[categ]*randomizer
        actual[categ] = rnorm(1, mean = diaMean[categ], sd = sdDia[categ])+ sdDia[categ]*randomizer
      }
      else {
        # actual[categ] = diaNonMean[categ] + sdNonDia[categ]*randomizer
        actual[categ] = rnorm(1, mean = diaNonMean[categ], sd = sdNonDia[categ])#+ sdNonDia[categ]*randomizer
      }
      diaInfo[i,categ] = actual[categ]
    }
  }
  if(actual[9]==0) {
    # if(actual[1]>60) {
    #   diaInfo[i,1] = diaInfo[i,1]-10
    # }
    # if(actual[6]>110) {
    #    diaInfo[i,6] = diaInfo[i,6] - 30
    # }
    if(actual[7]>1.5) {
      diaInfo[i,7] = diaInfo[i,7] - 1
    }
    if(actual[2]>170) {
      diaInfo[i,2] = diaInfo[i,2] - 30
    }
    if(actual[5]>300) {
      diaInfo[i,5] = diaInfo[i,5] - 200
    }
  } else {

  }
}
for(i in 1:8){
  minValue[i] = min(diaInfo[,i],na.rm = TRUE)
}
normalizeData = function(df) {
  for(i in 1:8){
    if(minValue[i] < 0) {
      df[,i] <- (df[,i]-minValue[i])
    }
    df[,i] <- (df[,i]/maxValue[i])*weight[i]
  }
  return(df)
}

dfAva <- normalizeData(diaAva)
dfInfo <- normalizeData(diaInfo)

write.csv(dfAva[1:8], file = 'Valuator.csv', row.names = FALSE)
write.csv(dfInfo[1:9], file = 'Output.csv', row.names = FALSE)


#!/usr/bin/env Rscript

# FLYCOP
# Author: Beatriz García-Jiménez
# April 2018

# Error in eval(substitute(select), nl, parent.frame()) :
#  object 'fitness' not found
# Calls: subset -> subset.data.frame -> eval -> eval
# Execution halted

suppressMessages(library(car))
suppressMessages(library(ellipse))
suppressMessages(library(RColorBrewer))

args = commandArgs(trailingOnly=TRUE)
if (length(args)<3) {
  stop("At least 3 arguments must be supplied: <domainName (string)> <experimentID (number)> <fitnessID (string)>", call.=FALSE)
} else {
  domainName=args[1]
  id=args[2]
  fitnessID=args[3]
}

# cleaning
suffix=paste("Scenario",id,sep="")
setwd(paste(domainName,'_scenario',id,'_FLYCOPdataAnalysis',sep=""))

my_colors <- brewer.pal(11, "RdYlBu")
my_colors=colorRampPalette(my_colors)(25)
data=read.csv('tableParamWithFitness.csv',sep='\t',header=TRUE)
formula=formula(paste("~",paste(colnames(data),collapse="+"),sep=""))

print("Chivato1")
header=paste(suffix,", Fitness=", fitnessID, sep="")
# correlation ellipse plot
corrMatrix<-cor(data)
pdf(paste('correlationEllipsePlot_',suffix,".pdf",sep=""),title=header)
plotcorr(corrMatrix, col=my_colors[corrMatrix*15+15], type="lower", mar=c(1,1,1,1), main=paste("Correlation plot.",suffix))
invisible(dev.off())
write.table(corrMatrix,paste('corrMatrix_',suffix,".txt",sep=""),quote=FALSE,sep="\t")
print("Chivato2")

# help(colorRampPalette)
# help(RColorBrewer)
# brewer.pal.info
# help(cor)
# help(plotcorr)

# Scatterplot, with lower diagonal with correlations:
panel.cor <- function(x, y, digits = 3, prefix = "", cex.cor=1, ...) # from help(pairs) # Only correlation, with modifications from below code
{
  usr <- par("usr"); on.exit(par(usr))
  par(usr = c(0, 1, 0, 1))
  # correlation coefficient
  r <- cor(x,y)
  txt <- format(c(r, 0.123456789), digits = digits)[1]
  txt <- paste("r= ", txt, sep = "")
  text(0.5, 0.6, txt, cex=1)
}
pdf(paste('scatterplotMatrix_',suffix,"_withCorr.pdf",sep=""),title=header)
scatterplotMatrix(formula, data=data, smooth=list(smoother=""),lower.panel=panel.cor,main=header)
invisible(dev.off())
print("Chivato3")
# help(scatterplotMatrix)

# Removing not stable configurations
# To retrieve standard deviation values:
tableSd=read.table('avgfitnessAndStdev.txt',sep=",",header=FALSE,row.names=NULL)
colnames(tableSd)=c('mean','sd')
pdf(paste('fitnessVsSd_',suffix,'.pdf',sep=""))
plot(tableSd,main=paste("Correlation plot.",suffix))
invisible(dev.off())
pdf(paste('fitnessVsSd_',suffix,'sdLt0.9.pdf',sep=""))
plot(tableSd[tableSd$sd<0.9,],main=paste("Correlation plot",suffix,'sd<0.9',sep=", "))
invisible(dev.off())
print("Chivato4")

# PROBLEMA --------------------------------------
data$sd=tableSd$sd
data <- subset(data,select=c(1:(length(data)-2),sd,fitFunc))
dataSorted <- data [with(data, order(-fitFunc)), ]
write.table(dataSorted,paste('dataTable_',suffix,".txt",sep=""),quote=FALSE,sep="\t",row.names=TRUE, col.names=TRUE)
data_sdLt0.9=data[data$sd<0.9,]
pdf(paste('scatterplotMatrix_',suffix,'sdLt0.9.pdf',sep=""),title=paste(header,'sd<0.9',sep=', '))
scatterplotMatrix(formula,data=data_sdLt0.9, smooth=list(smoother=""),lower.panel=panel.cor, main=paste(header,'sd<0.9',sep=', '))
invisible(dev.off())
# PROBLEMA -------------------------------------- FIN
print("Chivato5")

corrMatrix<-cor(data_sdLt0.9)
pdf(paste('correlationEllipsePlot_',suffix,'sdLt0.9.pdf',sep=""),title=paste(header,'sd<0.9',sep=', '))
plotcorr(corrMatrix, col=my_colors[corrMatrix*15+15], type="lower", mar=c(1,1,1,1), main=paste(header,'sd<0.9',sep=', '))
invisible(dev.off())
print("Chivato6")

sink(paste('corrMatrices_',suffix,'.txt',sep=''))
print('All configurations:')
print(dim(data)[1])
cor(data)
print('Sd<0.9:')
print(dim(data_sdLt0.9)[1])
cor(data_sdLt0.9)
sink()

# help(sink)


#' Convert a MODPATH pathline file into a simple feature (sf) object composed of linestring features
#'
#' This function takes as an argument a MODPATH pathline tibble (as generated using the readpathline
#' function) and converts the contents into an sf object. The pathline can be converted to real-world
#' coordinates using coordinate offsets and rotations. The pathline can also be modified by applying a
#' MAX_TIME limit that will only show pathlines that are less than or equal to the
#' threshold time limit (MAX_TIME).
#' @param df This is the data frame containing the pathline information. If this dataframe is not
#' present pth2sf will call readpathline using the supplied PATH. The default is NA.
#' @param X_off This is the global X coordinate offset.
#' @param Y_off This is the global Y coordinate offset.
#' @param ROT This is the rotation angle in units of degrees.
#' @param MAX_TIME is the maximum pathline travel time to be printed. This defaults to Inf.
#' @param PATH This is the full file path to the pathline file.
#' When PATH is NA and df is not supplied this function will look in the current working
#' directory for the pathline file.
#' @export

pth2sf <- function(df = NA, X_off = 0, Y_off = 0, ROT = 0, MAX_TIME = Inf, PATH = NA){
    if(is.na(df)){
        df <- MFtools::readpathline(PATH = PATH)
    }

    DF_SF <- df %>% MFtools::rot(X_off = X_off,
                                 Y_off = Y_off,
                                 ROT = ROT,
                                 Xin = GLOBAL_X,
                                 Yin = GLOBAL_Y) %>%
                    dplyr::select(-c(GLOBAL_X, GLOBAL_Y)) %>%
                    dplyr::rename(GLOBAL_X = Xout, GLOBAL_Y = Yout) %>%
                    dplyr::filter(CUMULATIVE_TIME <= MAX_TIME) %>%
                    sf::st_as_sf(coords = c("GLOBAL_X", "GLOBAL_Y"))

    PATH_SF <- DF_SF %>%
               dplyr::group_by(PART) %>%
               dplyr::summarise(do_union = FALSE) %>%
               sf::st_cast() %>%
               sf::st_cast("MULTILINESTRING") %>%
               dplyr::ungroup()

    return(PATH_SF)
}


library(destiny)

data(guo)

Dark2 <- scales::brewer_pal(palette = 'Dark2')
palette(Dark2(8L))

dm_guo <- DiffusionMap(guo, verbose = FALSE,
                       censor_val = 10, censor_range = c(10, 40))
plot(dm_guo,
     col = guo$num_cells, pch = 20)

sigmas <- find_sigmas(guo, verbose = FALSE,
                      censor_val = 10, censor_range = c(10, 40))
par(lwd = 3)
plot(sigmas,
    col           = palette()[[1]],
    col_highlight = palette()[[4]],
    col_line      = palette()[[6]])

dm_guo_global <- DiffusionMap(guo, sigmas, verbose = FALSE,
                              censor_val = 10, censor_range = c(10, 40))
plot(dm_guo_global,
     col = guo$num_cells, pch = 20)

#library(rgl)
#plot3d(eigenvectors(dm_guo)[, 1:3], col = guo$num_cells)


## Hankui wrote it on Nov 1, 2016
## confusion matrix
## source('confusion.r');

# source("getKappa.r");

confusion <- function(predicted, actual, filename="temp.csv")
{
	c_m <- as.matrix(table(Actual=actual, Predicted=predicted)) # create the confusion matrix
	# c_m <- as.data.frame(table(Predicted = predicted, Actual = actual )) # create the confusion matrix
	uniq_p <- sort(unique(predicted));
	uniq_t <- sort(unique(actual   ));
	nr      <- nrow(c_m) # number of classes

	##***************************************************************
	## important for those classes never been classified (Mar 13 2018 Hank)
	block_list <- list();
	zeros <- rowsums <- apply(c_m, 1, sum)*0;
	empty_index <- vector();
	for (i in 1:length(uniq_t)) {
		nc <- ncol(c_m);
		is_find <- 0;
		uniq_t_i <- uniq_t[i];
		for (j in 1:length(uniq_p)) if (uniq_p[j]==uniq_t_i) {is_find <- j; break; }

		if(is_find==0) {
			block_list[[i]] <- zeros;
			cat("\tclass", uniq_t_i, "is never predicted\n");
			empty_index <- c(empty_index, i);
		}  else {
			block_list[[i]] <- c_m[,is_find];
		}
	}
	c_m_new <- block_list[[1]];
	for (i in 2:length(uniq_t)) c_m_new <- cbind(c_m_new, block_list[[i]]);

	c_m <- c_m_new;
	colnames(c_m) <- rownames(c_m);

	##***************************************************************
	## accuracy
	n <- sum(c_m) # number of instances
	diags   <- diag(c_m) # number of correctly classified instances per class
	rowsums <- apply(c_m, 1, sum) # number of instances per class
	colsums <- apply(c_m, 2, sum) # number of predictions per class

	accuracy = sum(diags) / n;
	# print(c_m)
	# print(accuracy)
	# precision = diags / colsums
	# recall = diags / rowsums
	uses     <- diags / colsums * 100;
	produces <- diags / rowsums * 100;
	c_m <- cbind(c_m, rowsums, produces);

	colsumss <- c(colsums, n, 0       );
	uses.s   <- c(uses   , 0, accuracy);
	c_m <- rbind(c_m, colsumss, uses.s);

	# colnames(c_m) <- c(colnames(c_m)[1:nr],"Total truth","Producer's accuracy");
	# rownames(c_m) <- c(rownames(c_m)[1:nr],"Total predicted","User's accuracy");
	rownames(c_m) <- c(as.numeric(colnames(c_m)[1:nr])-1,"Total truth","Producer's accuracy");
	colnames(c_m) <- c(as.numeric(rownames(c_m)[1:nr])  ,"Total predicted","User's accuracy");

	# print(precision)
	options(scipen=999);
	# print(format(c_m, digits=1));
	write.csv(c_m, file=filename);

	## *******************************************************************************************
	## Kappa
	ppp <- rowsums / n; # distribution of instances over the actual classes
	qqq <- colsums / n; # distribution of instances over the predicted classes
	expAccuracy = sum(ppp*qqq);
	Kappa = (accuracy - expAccuracy) / (1 - expAccuracy);
	cat("\tKappa = ");
	cat(format(Kappa, digits=4));
	cat("\tAccuracy = ");
	print(format(accuracy*100, digits=4));
	list("Kappa"=Kappa, "Accuracy"=accuracy, "Confusion"=c_m);
}
## *******************************************************************************************
## test data
# set.seed(0)
# actual = c('a','b','c')[runif(100, 1,4)] # actual labels
# predicted = actual # predicted labels
# predicted[runif(30,1,100)] = actual[runif(30,1,100)]  # introduce incorrect predictions
# predicted[runif(30,1,10)] = c('a','b','c')[runif(10, 1,4)]  # introduce incorrect predictions
# confusion(predicted, actual);

## *******************************************************************************************
## test data global random forest
# prop <- 67;
# prop <- 100;
# load(paste("./file.plot/conus.urbanFALSE.prop",prop,".tree500", sep=""));
# actual <- truth;
# confusion(predicted, actual, "global.confusion.csv");


xx <- rep("", 100)
x <- 1:100
xx[x %% 3 == 0] <- paste0(xx[x %% 3 == 0], "Fizz")
xx[x %% 5 == 0] <- paste0(xx[x %% 5 == 0], "Buzz")
xx[xx == ""] <- x[xx == ""]
xx


# Demo for shapes
par(ask=TRUE)

##drapecol
 persp(volcano,theta = 135, phi = 30, col = drapecol(volcano),main="drapecol,femmecol")

##intpalette
 intpalette(c("white","black"),n=10)
 grey(seq(1,0,length.out=10))
 image(matrix(nrow=1,ncol=100,data=1:100),main="intpalette",
 col=intpalette(c("red","blue"),numcol=100))
 image(matrix(nrow=1,ncol=100,data=1:100),main="intpalette",
 col=intpalette(c("red","blue","yellow"),numcol=100))
 image(matrix(nrow=1,ncol=100,data=1:100),main="intpalette",
 col=intpalette(c("red","blue","yellow","green"),numcol=100))
 image(matrix(nrow=1,ncol=100,data=1:100),main="intpalette",
 col=intpalette(c("red","blue","yellow","green","black"),numcol=100))

##shadepalette
 shadepalette(n=10,"white","black")
 image(matrix(nrow=1,ncol=100,data=1:100),col=shadepalette(100,"red","blue"),
       main="shadepalette")
# rotatexy
#----------------
xy <- matrix(ncol=2,data=c(1:5,rep(1,5)))
plot(xy,xlim=c(-6,6),ylim=c(-6,6),type="b",pch=16,main="rotatexy",col=1)
for ( i in 1:5) points(rotatexy(xy,mid=c(0,0),angle=60*i),col=i+1,type="b",pch=16)
points(0,0,cex=2,pch=22,bg="black")

legend("topright",legend=60*(0:5),col=1:6,pch=16,title="angle")
legend("topleft",legend="midpoint",pt.bg="black",pt.cex=2,pch=22,box.lty=0)

x <- seq(0,2*pi,pi/100)
y <- sin(x)
cols <- intpalette(c("blue","green","yellow","red"),n=250)
cols <- c(cols,rev(cols))
plot(x,y,type="l",ylim=c(-3,3),main="rotatexy",col=cols[1],lwd=2,xlim=c(-1,7))
for (i in 2:500) lines(rotatexy(cbind(x,y),angle=0.36*i),col=cols[i],lwd=2)

x <- seq(0,2*pi,pi/100)
y <- sin(x*2)

cols <- intpalette(c("red","yellow","black"),n=250)
cols <- c(cols,rev(cols))
plot(x,y,type="l",ylim=c(-4,5),main="rotatexy, asp=TRUE",col=cols[1],lwd=2,xlim=c(-1,7))
for (i in 2:500) lines(rotatexy(cbind(x,y),angle=0.36*i,asp=TRUE),col=cols[i],lwd=2)

cols <- femmecol(1000)
plot(x,y,xlim=c(-1,1),ylim=c(-1,1),main="rotatexy",col=cols[1],type="n")
for (i in 2:1000) {xy<-rotatexy(c(0,1),angle=0.36*i, mid=c(0,0));
                    points(xy[1],xy[2],col=cols[i],pch=".",cex=2)}

# ellipses
#----------------
emptyplot(c(-1.5,1.5))
cols <- rainbow(10)
SS   <- rev(seq(0.1,1,0.1))
plotellipse(rx=1.5,ry=0.6)
plotellipse(rx=1.2,ry=0.4)
for (i in 1:length(SS)) plotellipse(1,SS[i],col=cols[i],type="n")
title("plotellipse")
plotellipse(rx=1.5,ry=0.6,angle=0,from=pi,to=2*pi,arrow=TRUE,arr.pos=0.5)
plotellipse(rx=1.2,ry=0.4,from=pi,to=2*pi)

#
emptyplot(c(-1.,1.))
col  <- shadepalette(endcol="darkblue",n=100)
filledellipse (rx1=1,ry1=0.8,col=col,lcol="black")
plotellipse(rx=1,ry=0.35 ,angle=0,from=pi,to=2*pi,lwd=1,mid=c(0,0.))
plotellipse(rx=1.1,ry=0.6 ,angle=0,from=1.28*pi,to=1.72*pi,lwd=1,mid=c(0,-0.1))
plotellipse(rx=0.9 ,ry=0.32,angle=0,from=pi,to=2*pi,lwd=1,mid=c(0,0.35))
plotellipse(rx=0.65,ry=0.25,angle=0,from=pi,to=2*pi,lwd=1,mid=c(0,0.6))
plotellipse(rx=0.3 ,ry=0.1,angle=0,from=pi,to=2*pi,lwd=1,mid=c(0,0.75))

plotellipse(rx=0.8,ry=0.0,angle=90,from=pi,to=2*pi,lwd=1)
plotellipse(rx=0.8,ry=0.35,angle=90,from=pi,to=2*pi,lwd=1)
plotellipse(rx=0.8,ry=0.6,angle=90,from=pi,to=2*pi,lwd=1)
plotellipse(rx=0.8,ry=0.8,angle=90,from=pi,to=2*pi,lwd=1)

plotellipse(rx=0.8,ry=0.35,angle=-90,from=pi,to=2*pi,lwd=1)
plotellipse(rx=0.8,ry=0.6,angle=-90,from=pi,to=2*pi,lwd=1)
plotellipse(rx=0.8,ry=0.8,angle=-90,from=pi,to=2*pi,lwd=1)
title("plotellipse, filledellipse")

#
emptyplot(c(-1,1))
col  <- c(rev(greycol(n=50)),greycol(50))
filledellipse(rx1=1,rx2=0.5,dr=0.01,col=col)
title("filledellipse")

#
emptyplot(c(-1,1),c(-1,1))
filledellipse(col=col)
title("filledellipse")

#
color <-graycol(n=50)
dr    <- 0.05
emptyplot(xlim=c(-2,2),ylim=c(-2,2),col=color[length(color)])

filledellipse(rx1=1,mid=c(1,1)  ,col=shadepalette(endcol="darkblue") ,dr=dr)
filledellipse(rx1=1,mid=c(-1,-1),col=shadepalette(endcol="darkgreen"),dr=dr)
filledellipse(rx1=1,mid=c(1,-1) ,col=shadepalette(endcol="darkred")   ,dr=dr)
filledellipse(rx1=1,mid=c(-1,1) ,col=shadepalette(endcol="darkviolet"),dr=dr)
filledellipse(rx1=1,col=color,dr=dr)
title("filledellipse")

#
color <-gray(seq(1,0.3,length.out=50))
emptyplot(xlim=c(-2,2),ylim=c(-2,2),col=color[length(color)])

filledellipse(rx1=2,ry1=0.4,col=color,angle=45,dr=dr)
filledellipse(rx1=2,ry1=0.4,col=color,angle=-45,dr=dr)
filledellipse(rx1=2,ry1=0.4,col=color,angle=0,dr=dr)
filledellipse(rx1=2,ry1=0.4,col=color,angle=90,dr=dr)
title("filledellipse")

example(getellipse)

# cylinder
#----------------
example(cylindersegment)

example(filledcylinder)
# shape
#----------------
emptyplot(c(-1.,1.))
xy <- getellipse(rx=1,ry=0.4)
filledshape(xyouter=xy,xyinner=c(0,1.),col=femmecol(100))
title("filledshape")

example(filledshape)

emptyplot(col="darkgrey",main="filledshape")
filledshape(matrix(nc=2,runif(100)),col=shadepalette(200,"darkred","darkblue"))

# rectangle
#----------------
example(filledrectangle)

# multigonal
#----------------

color <-shadepalette(grey(0.3),"blue",n=50)
emptyplot(c(-1,1))
filledmultigonal(rx=0.25,ry=0.25,col=shadepalette(grey(0.3),"blue",n=50),nr=3,mid=c(0,0),angle=0)
filledmultigonal(rx=0.25,ry=0.25,col=shadepalette(grey(0.3),"darkgreen",n=50),nr=4,mid=c(0.5,0.5),angle=90)
filledmultigonal(rx=0.25,ry=0.25,col=shadepalette(grey(0.3),"orange",n=50),nr=5,mid=c(-0.5,-0.5),angle=-90)
filledmultigonal(rx=0.25,ry=0.25,col="black",nr=6,mid=c(0.5,-0.5),angle=180)
filledmultigonal(rx=0.25,ry=0.25,col="white",lcol="black",nr=7,mid=c(-0.5,0.5),angle=270)
title("filledmultigonal")

example(filledmultigonal)

# Pipes
xlim <- ylim <- c(-20,20)
emptyplot(xlim)
box()

color  <- graycol(n=5)
color  <- c(rev(color),color)
maxlen <- 15
maxrad <- 1.0

dr    <- 0.01
angle <- 0
mid   <- c(0,0)
ry    <- 0

numpipes <- 100
for (i in 1:numpipes)
{

rnd    <- runif(1)       # jump length
length <- maxlen*rnd
newpos <- rotatexy(mid+c(length+2*maxrad,0),angle,mid)

                         # check if within boundaries
if (! (newpos[1] > xlim[1] & newpos[1] < xlim[2] &
       newpos[2] > ylim[1] & newpos[2] < ylim[2])) length <- 0

                         # rectangle
mid <- rotatexy(mid+c(length/2,0),angle,mid)
filledrectangle(wy=maxrad,wx=length,col=color,angle=angle,mid=mid)
mid <- rotatexy(mid+c(length/2,0),angle,mid)

rnd    <- runif(1)        # new angle
                                dangle <- 0
if (rnd <= 0.3333)              dangle <- 90
if (rnd >0.3333 & rnd < 0.6666) dangle <- - 90

piangle <- angle / 180 * pi

if (dangle == 90)  # left turn
 {
 mid <- rotatexy(mid+c(0,maxrad/2),angle,mid)
 filledcircle(r1=maxrad,r2=ry,col=color,mid=mid,dr=dr,from= piangle-pi/2,to= piangle)
 mid <- rotatexy(mid+c(maxrad/2,0),angle,mid)
 }

if (dangle ==-90)  # right turn
{
 mid <- rotatexy(mid-c(0,maxrad/2),angle,mid)
 filledcircle(r1=maxrad,r2=ry,col=color,mid=mid,dr=dr,from= piangle,to= piangle+pi/2)
 mid <- rotatexy(mid+c(maxrad/2,0),angle,mid)
}
angle <- angle + dangle
if (angle >= 360) angle <- angle - 360
if (angle < 0)    angle <- angle + 360

}
title("filledrectangle,filledcircle")

# Arrowhead
#----------------

emptyplot(c(0,1))

Arrowhead(x0=runif(10),y0=runif(10),angle=runif(10)*360,
arr.length=0.4,arr.type="circle",arr.col="green")

Arrowhead(x0=runif(10),y0=runif(10),angle=runif(10)*360,
arr.length=0.6,arr.type="curved",arr.col="red")

Arrowhead(x0=runif(10),y0=runif(10),angle=runif(10)*360,
arr.length=0.6,arr.type="triangle",arr.col="blue")

title("Arrowhead")

# Arrows
#----------------
example(Arrows)
xlim <- c(-5 ,5)
ylim <- c(-10,10)
plot(0,type="n",xlim=xlim,ylim=ylim)
x0<-runif(100,xlim[1],xlim[2])
y0<-runif(100,ylim[1],ylim[2])
x1<-x0+runif(100,-1,1)
y1<-y0+runif(100,-1,1)
size <- 0.6
ang  <- runif(100,-360,360)
Arrows(x0,y0,x1,y1,arr.length=size,code=2,arr.type="curved",arr.col="white")
title("Arrows")

plot(0,type="n",xlim=xlim,ylim=ylim)
Arrows(x0,y0,x1,y1,arr.length=size,code=2,arr.type="triangle",arr.col="yellow")
title("Arrows")

plot(0,type="n",xlim=xlim,ylim=ylim)
x0<-runif(100,xlim[1],xlim[2])
y0<-runif(100,ylim[1],ylim[2])
x1<-x0+runif(100,-1,1)
y1<-y0+runif(100,-1,1)
size <- 0.6
ang  <- runif(100,-360,360)
Arrows(x0,y0,x1,y1,arr.length=size,code=2,arr.type="circle",arr.col="darkblue")
title("Arrows")

# Lotka-Volterra competition model
r1    <- 3              # parameters
r2    <- 2
K1    <- 1.5
K2    <- 2
alf12 <- 1
alf21 <- 2

Ax  <- c(0,K2/alf21)
Ay  <- K2 - alf21* Ax
By  <- c(0,K1/alf12)
Bx  <- K1 - alf12* By
xlim   <- range(c(Ax, Bx))
ylim   <- range(c(Ay, By))

plot  (x=Ax,y=Ay, type="l",lwd=3,   # 1st isocline
     main="Arrows",sub="Model from Soetaert and Herman, 2008. book",
       xlab="N1",ylab="N2",xlim=xlim,ylim=ylim)
lines (Bx,By, lty=2,lwd=3)            # 2nd isocline

gx <- seq(0,1.5,len=40)
gy <- seq(0,2,len=40)
N  <- as.matrix(expand.grid(x=gx,y=gy))

dN1 <- r1*N[,1]*(1-(N[,1]+alf12* N[,2])/K1)
dN2 <- r2*N[,2]*(1-(N[,2]+alf21* N[,1])/K2)
dt  <- 0.0001
Arrows(N[,1],N[,2],N[,1]+dt*dN1,N[,2]+dt*dN2,arr.len=0.15, lcol=grey(0.4),arr.type="triangle")
points(x=c(0,0,1.5,0.5),y=c(0,2,0,1),pch=22,cex=2,bg=c("white","black","black","grey"))

example(colorlegend)

# Scientific example of use of filledellipse: uses values
BW     <- 10           # mmol/m3,       oxygen concentration in surrounding water
Da     <- 0.5          # cm2/d          effective diffusion coefficient in organism
R      <- 0.005        # cm             radius of organism
Q      <- 250000       # nM/cm3/d       oxygen consumption rate per volume per day

# concentration in spherical organism body
sphere   <- function(Da,Q,BW,R,r)  BW+Q/(6*Da)*(r^2-R^2)

# distance in organism body
color <- femmecol(100)

zlim=c(0,BW)
emptyplot(c(-3.3,3.3),col=color[length(color)],main="Oxygen concentration in spherical organism",
sub="Model from Soetaert and Herman, 2008. book")
R      <- 0.005
values <- cbind(rr<-seq(0,R,length=50),sphere(Da,Q,BW,R,rr))

filledellipse(rx1=R*100,mid=c(-2,2),values=values,zlim=zlim,col=color,lcol="black",lwd=1)

R      <- 0.0075
values <- cbind(rr<-seq(0,R,length=50),sphere(Da,Q,BW,R,rr))
filledellipse(rx1=R*100,mid=c(0,2),values=values,zlim=zlim,col=color,lcol="black",lwd=1)

R      <- 0.010
values <- cbind(rr<-seq(0,R,length=50),sphere(Da,Q,BW,R,rr))
filledellipse(rx1=R*100,mid=c(2,2),values=values,zlim=zlim,col=color,lcol="black",lwd=1)

R      <- 0.015
values <- cbind(rr<-seq(0,R,length=100),sphere(Da,Q,BW,R,rr))
filledellipse(rx1=R*100,mid=c(-1,-1),values=values,zlim=zlim,col=color,lcol="black",lwd=1)

segments(-1.5,-3,-0.5,-3,lwd=2,col="black")
text(-1,-2.8,"10 microm")

colorlegend(zlim=zlim,posy=c(0.05,0.5),posx=c(0.7,0.73),font=2,
main="micromol/l",main.cex=1.2)


# Since R 3.0.0, the base package provides bitwise operators, see ?bitwAnd

a <- 35
b <- 42
bitwAnd(a, b)
bitwOr(a, b)
bitwXor(a, b)
bitwNot(a)
bitwShiftL(a, 2)
bitwShiftR(a, 2)

# See also http://cran.r-project.org/src/base/NEWS.html


#!/usr/bin/env Rscript

library(ggplot2)
library(gridExtra)
library(reshape2)

X <- read.delim("./output/opt_result.csv", sep=",", header=FALSE)
X$cluster <- as.factor(X$V3)
summary(X)
p <-ggplot(data=X) +
	geom_point(aes(V1, V2, shape = cluster, color = cluster)) +
	facet_wrap( ~ V4) +
ggsave(file="./img/opt_iters.png", width=8, height=8, dpi=100)

Y <- read.delim("./output/opt_error.csv", sep=",", header=FALSE)
#summary(Y)
colnames(Y) <- c("Iteration","TrainErr","XValidErr")
YY <- melt(Y, id=("Iteration"))
summary(YY)
p1 <-ggplot(data=YY) +
	geom_point(aes(Iteration,value, color=variable)) +
	geom_line(aes(Iteration, value, color=variable)) +
	scale_y_log10() +
	ylab("Normalized Error")
ggsave(file="./img/opt_error.png", width=4, height=4, dpi=100)


#!/usr/bin/Rscript

# Bhishan Poudel
# Jan 10, 2016

# clear; Rscript rs3class.r; rm *~
# ref: http://www.programiz.com/r-programming/S3-class
# 5 data types in R : vectors, matrix, list, data frame and a factor
########################################################
# Defining S3 Class and Creating S3 Objects

# create a list with required components
s <- list(name="John", age=21, GPA=3.5)
# name the class appropriately
class(s) <- "student"; s

# a constructor function for the "student" class
student <- function(n,a,g) {
# we can add our own integrity checks
if(g>4 || g<0)  stop("GPA must be between 0 and 4")
value <- list(name=n, age=a, GPA=g)
# class can be set using class() or attr() function
attr(value, "class") <- "student"
value
}

# Here is a sample run where we create objects using this constructor.
s <- student("Paul", 26, 3.7);s
# we get error for this
#s <- student("Paul", 26, 5)

# it's up to us to maintain it or not
s$GPA <- 5; s


hand_data <- read.csv(file="D:/paula/Documents/NotFun/Studium/Master_Geoinformatics/GECCO/GECCO/logs/log.log",head=TRUE,sep=" ")
hand_data <- transform(hand_data, timestamp = (timestamp - hand_data[1,1]))
hand_data <- transform(hand_data, height = (height * 0.001))

################################################################################
library(ggplot2)
ggplot(hand_data, aes(x = x, y = 720-y)) +
  coord_equal() +
  xlab('x') +
  ylab('y') +
  xlim(0, 1080) +
  ylim(0, 720) +
  stat_density2d(aes(fill = ..level..), alpha = .5,
                 geom = "polygon", data = hand_data) +
  scale_fill_viridis_c() +
  theme(legend.position = 'right') +
  geom_point(aes(x,720-y), size=5,shape=".")

ggplot(hand_data, aes(x = x, y = 720-y)) +
  coord_equal() +
  xlab('x') +
  ylab('y') +
  xlim(0, 1080) +
  ylim(0, 720) +
  stat_density2d(aes(color = ..level..), alpha = .5,
                 geom = "polygon", data = hand_data) +
  scale_fill_viridis_c() +
  theme(legend.position = 'right') +
  geom_point(aes(x,720-y), size=5,shape=".")

ggplot(hand_data, aes(x = x, y = 720-y)) +
  geom_point(aes(x,720-y), size=5,shape=".") +
  coord_equal() +
  xlab('x') +
  ylab('y') +
  xlim(0, 1080) +
  ylim(0, 720) +
  stat_density2d(aes(fill= ..density..), alpha = .5,
                 geom = "raster", data = hand_data, contour=FALSE) +
  scale_fill_viridis_c() +
  theme(legend.position = 'right')

ggplot(hand_data, aes(x = x, y = 720-y)) +
  coord_equal() +
  xlab('x') +
  ylab('y') +
  xlim(0, 1080) +
  ylim(0, 720) +
  stat_density2d(aes(fill= ..density..), alpha = .5,
                 geom = "raster", data = hand_data, contour=FALSE, h=c(300,300)) +
  scale_fill_viridis_c() +
  theme(legend.position = 'right')


library(ade4)
library(car)
library(corrplot)
library(dplyr)
library(gtools)
library(lmtest)
library(outliers)
library(psych)
library(randtests)
library(readxl)
library(readr)
library(strucchange)
library(skedastic)
library(tidyr)

set.seed(307)
alpha <- 0.05
dataset <- read.csv('bmw1.csv')

# --- Missing values ----------------------------------
colSums(is.na(dataset))
dataset <- missing_values(dataset)
colSums(is.na(dataset))
dataset <- as.data.frame(dataset)

stats <- describe(dataset)
table(dataset$model)
table(dataset$fuelType)
table(dataset$transmission)

# --- cor ---------------------------------------------
corr <- cor(cbind.data.frame(dataset$price, dataset$year, dataset$mileage, dataset$tax,
                             dataset$mpg, dataset$engineSize))
colnames(corr) <- rownames(corr) <- c('price', 'year', 'mileage', 'tax', 'mpg', 'engineSize')
col <- colorRampPalette(c("#BB4444", "#EE9988", "#FFFFFF", "#77AADD", "#4477AA"))
corrplot::corrplot(corr, method="color", col=col(200),
                   type="upper", order="hclust",
                   addCoef.col = "black",
                   tl.col="black", tl.srt=45,
                   diag=FALSE
)

# --- Outliers ----------------------------------------
dataset <- outliers_grubbs(dataset, 0.05)

# --- categorical variables to binary variables -------
dataset <- cbind(dataset$price,
                 as.data.frame(acm.disjonctif(as.data.frame(dataset[,1]))), dataset$year,
                 as.data.frame(acm.disjonctif(as.data.frame(dataset[,4]))), dataset$mileage,
                 as.data.frame(acm.disjonctif(as.data.frame(dataset[,6]))), dataset$tax,
                 dataset$mpg, dataset$engineSize)
colSums(dataset)

#removing binary variables which has no observations
dataset <- dataset[, -which(colnames(dataset)=="dataset[, 1]. i3")]
dataset <- dataset[, -which(colnames(dataset)=="dataset[, 1]. i8")]
dataset <- dataset[, -which(colnames(dataset)=="dataset[, 1]. M5")]
dataset <- dataset[, -which(colnames(dataset)=="dataset[, 1]. M6")]
dataset <- dataset[, -which(colnames(dataset)=="dataset[, 1]. Z3")]
dataset <- dataset[, -which(colnames(dataset)=="dataset[, 6].Electric")]
dataset <- dataset[, -which(colnames(dataset)=="dataset[, 6].Other")]

# removing one binary variable for each category (model, transmission, fuelType)
dataset <- dataset[, -which(colnames(dataset)=="dataset[, 1]. Z4")]
dataset <- dataset[, -which(colnames(dataset)=="dataset[, 4].Semi-Auto")]
dataset <- dataset[, -which(colnames(dataset)=="dataset[, 6].Hybrid")]

# --- colnames -----------------------------------------
colnames(dataset) <- c('price', 'model_1', 'model_2',
                       'model_3', 'model_4', 'model_5',
                       'model_6', 'model_7', 'model_8',
                       'model_M2', 'model_M3', 'model_M4',
                       'model_X1', 'model_X2', 'model_X3',
                       'model_X4', 'model_X5', 'model_X6', 'model_X7',
                       'year', 'transmission_Automatic', 'transmission_Manual',
                       'mileage', 'fuelType_Diesel', 'fuelType_Petrol', 'tax',
                       'mpg', 'engineSize')

# variable: age and mpy ----------------------
dataset$age <- 2021 - dataset$year
dataset$mpy <- dataset$mileage/dataset$age

# removing variable year
dataset <- dataset[, !names(dataset) %in% c("year")]

# --- training and testing dataset ---------------------
dt = sort(sample(nrow(dataset), nrow(dataset)*.8))
training_set <- dataset[dt,]
testing_set <- dataset[-dt,]

# step method
model <- lm(price~., data = training_set)
summary(model)
s <- step(model, direction = 'backward')$model
model <- lm(price ~ ., data = s)
summary(model)

# choosing variables based on correlations, then step method
corr <- cor(dataset)
corr[1,]

training_set <- training_set[, names(training_set) %in% c('price', 'model_X5',
                                                          'transmission_Manual', 'mileage', 'tax', 'mpg', 'engineSize', 'age', 'mpy')]

model <- lm(price~., data = training_set)
summary(model)
s <- step(model, direction = 'backward')$model
model <- lm(price ~ ., data = s)
summary(model)

training_set <- training_set[, !names(training_set) %in% c('engineSize', 'mpy')]

model <- lm(price~., data = training_set)
summary(model)

# four possible models

model1 <- lm(price~., data = training_set)
summary(model1)

model2 <- lm(log(price)~., data = training_set)
summary(model2)

model3 <- lm(log(price) ~ model_X5 + transmission_Manual + log(mileage) + tax + log(mpg) + log(age), data = training_set)
summary(model3)

model4 <- lm(price ~ model_X5 + transmission_Manual + log(mileage) + tax + log(mpg) + log(age), data = training_set)
summary(model)

AIC(model1)
BIC(model1)
AIC(model2)
BIC(model2)
AIC(model3)
BIC(model3)
AIC(model4)
BIC(model4)

# -- model I -------
shapiro.test(model2$residuals)

bptest(model2)
skedastic::white_lm(model2, interactions = T)

for(i in 2:ncol(training_set))
  print(gqtest(model2, alternative = 'two.sided',
               order.by = ~ training_set[,i], data = training_set)$p.value)

# WLS

ln_e2 <- log(model2$residuals^2)
resid_model <- lm(ln_e2 ~ training_set$mileage +
                    training_set$tax + training_set$mpg + training_set$age)
w <- exp(resid_model$fitted.values)
model_wmnk <- lm(log(price)~., training_set, weights = 1/w)
summary(model_wmnk)
e <- (1/sqrt(w)*model_wmnk$residuals)

shapiro.test(e)
tseries::jarque.bera.test(e)

ncvTest(model_wmnk, var.formula = ~ model_X5 + transmission_Manual + training_set$mileage +
          training_set$tax + training_set$mpg + training_set$age)

corr <- cor(training_set)
corr[1,]

sctest(model_wmnk, data = training_set,type="Chow", point=floor(dim(training_set)[1]/2))
runs.test(e)
car::vif(model_wmnk)

# prediction
prediction <- exp(predict(model_wmnk, testing_set))
expost_error <- as.data.frame(testing_set$price - prediction)
ME <- mean(expost_error)
MAE <- mean(abs(expost_error))
MSE <- mean(expost_error^2)
RMSE <- MSE ^ 0.5
pred_y <- cbind(as.data.frame(prediction), testing_set$price)


library(caTools)

lines <- scan("input.txt", character(), quote="")
chars <- strsplit(lines, "")
seats <- do.call(rbind, chars)

# The boat's dimensions:
r <- nrow(seats)
c <- ncol(seats)

# So, this is basically like Conway's Game of Life, with some extra twists.
# There's floors and seats. Seats follow modified Life rules:
#  If its neighbor count is 0, it becomes full (1)
#  If its neighbor count is 4+, it empties     (0)
#  Otherwise, no change.
# Floors are always empty and never change.

# Let's make a MASK out of the floors, in which 0 is not a floor, and
#  1 is a floor.
floor <- matrix(0, r, c)
floor[seats=="."] <- 1

curr_layout <- matrix(0, r, c) # Boats start empty.
prev_layout <- matrix(2, r, c) # Create an invalid "previous" layout

# Now we've got a floor mask (floor), and a matrix of where people are
#  sitting (curr_layout), and a matrix of where people were previously
#  sitting (prev_layout), which is invalid for the first run so we'll always
#  loop at least once.

gif_storage = array(0, c(r,c,100))
steps <- 0

# So, we're off to see the wizard.
while (!all(curr_layout == prev_layout)) {

     steps <- steps+1

     # Ok, this next part is really fiddly. We're going to make 8 new matrices
     #  by shifting the values in curr_layout around: in each cardinal direction,
     #  and then also in every diagonal direction. Because curr_layout contains
     #  only 0s and 1s, summing these resulting matrices together will yield a
     #  matrix where each value is the number of NEIGHBORS of that seat position.

     cnt_from_l <- cbind(rep(0, r), curr_layout[,-c]) # Shift values RIGHT into a new matrix
     cnt_from_r <- cbind(curr_layout[,-1], rep(0, r)) # Shift values LEFT into a new matrix
     cnt_from_u <- rbind(rep(0, c), curr_layout[-r,]) # Shift values DOWN into a new matrix
     cnt_from_d <- rbind(curr_layout[-1,], rep(0, c)) # Shift values UP into a new matrix

     cnt_from_lu <- rbind(rep(0, c), cbind(rep(0, r-1), curr_layout[-r,-c])) # RIGHT+DOWN
     cnt_from_ld <- rbind(cbind(rep(0, r-1), curr_layout[-1,-c]), rep(0, c)) # RIGHT+UP
     cnt_from_ru <- rbind(rep(0, c), cbind(curr_layout[-r,-1], rep(0, r-1)))  # LEFT+DOWN
     cnt_from_rd <- rbind(cbind(curr_layout[-1,-1], rep(0, r-1)), rep(0, c)) # LEFT+UP

     # Sum these up.
     neighbor_cnt <- cnt_from_l + cnt_from_r + cnt_from_u + cnt_from_d +
                    cnt_from_lu + cnt_from_ld + cnt_from_ru + cnt_from_rd

     gif_storage[,,steps] <- neighbor_cnt
     gif_storage[,,steps][floor == 1] <- 0

     # Use our current layout as the starting point for the next one:
     next_layout <- curr_layout

     # Logical subscripting makes this next part easy!
     #  If a seat's neighbor count is 0, it becomes full (1)
     next_layout[neighbor_cnt == 0] <- 1
     #  If its neighbor count is 4+, it empties     (0)
     next_layout[neighbor_cnt >= 4] <- 0
     #  Otherwise, no change.

     # However! Nobody is allowed to sit on the floor. Mask it off.
     next_layout[floor == 1] <- 0

     prev_layout <- curr_layout
     curr_layout <- next_layout
}

gif_storage <- gif_storage[,,1:steps]/max(gif_storage)
write.gif(gif_storage, "part1.gif", col="jet", delay=15)

# How many butts are in seats once this thing stabilizes?
print(sum(curr_layout==1))


#
# This is a Shiny web application. You can run the application by clicking
# the 'Run App' button above.
#
# Find out more about building applications with Shiny here:
#
#    http://shiny.rstudio.com/
#

library(shiny)
library (ggplot2)
# Define UI for application that draws a histogram
ui <- fluidPage(

    # Application title
    titlePanel("Graph Data"),

    # Sidebar with a slider input for number of bins
    sidebarLayout(
        sidebarPanel(

            # Input: Select a file ----
            fileInput("file1", "Choose CSV File",
                      multiple = FALSE,
                      accept = c("text/csv",
                                 "text/comma-separated-values,text/plain",
                                 ".csv")),

            # Horizontal line ----
            tags$hr(),

            # Input: Checkbox if file has header ----
            checkboxInput("header", "Header", TRUE),

            # Input: Select separator ----
            radioButtons("sep", "Separator",
                         choices = c(Comma = ",",
                                     Semicolon = ";",
                                     Tab = "\t"),
                         selected = ","),

            # Input: Select quotes ----
            radioButtons("quote", "Quote",
                         choices = c(None = "",
                                     "Double Quote" = '"',
                                     "Single Quote" = "'"),
                         selected = '"'),

            # Horizontal line ----
            tags$hr(),

            # Input: Select number of rows to display ----
            radioButtons("disp", "Display",
                         choices = c(Head = "head",
                                     All = "all"),
                         selected = "head"),

            actionButton("lmPlot", "Linear Model"),
            tags$hr(), # Horizontal line
            downloadButton('downloadPlot', 'Download Plot')
        ),

        # Show a plot of the generated distribution
        mainPanel(
           plotOutput("distPlot"),
           plotOutput("lmPlot"),
           h4("Rsquared"),
           textOutput("Rsquared"),
           h4("Intercept"),
           textOutput("Intercept"),
           h4("Slope"),
           textOutput("Slope"),

        )
    )
)

# Define server logic required to draw a histogram
server <- function(input, output) {

    dataInput <- reactive({
        req(input$file1)

        df <- read.csv(input$file1$datapath,
                       header = input$header,
                       sep = input$sep,
                       quote = input$quote)
        return(df)
    })

    LinearModel <- eventReactive(input$lmPlot, {
        y <- dataInput()$y
        x <- dataInput()$x
        lmPlot <- lm(y ~ x)

    })

    output$distPlot <- renderPlot({
        plot(dataInput()$x,dataInput()$y)
    })

    lmGraph <- function(){
        plot(dataInput()$x,dataInput()$y)
        abline(LinearModel())

    }

    output$lmPlot <- renderPlot({
        # y <- dataInput()$y
        # x <- dataInput()$x
        # lmPlot <- lm(y ~ x)
       # plot(dataInput()$x,dataInput()$y)
        # abline(LinearModel())
        lmGraph()

    })
     output$summary <- renderText({

       paste("R2 = ",signif(summary(LinearModel())$r.squared, 5),
              "Intercept =",signif(LinearModel()$coef[[1]],5 ),
              "Slope =",signif(LinearModel()$coef[[2]], 5))

    })

     output$Rsquared <- renderText({

         paste("R2 = ",signif(summary(LinearModel())$r.squared, 5))

     })

     output$Intercept <- renderText({

         paste("Intercept =",signif(LinearModel()$coef[[1]],5))

     })

     output$Slope <- renderText({

         paste("Slope =",signif(LinearModel()$coef[[2]], 5))

     })

     output$downloadPlot <- downloadHandler(
         filename = function() { paste(input$file1$datapath, '.png', sep='') },
         content = function(file) {
             png(file)
             lmGraph()
             dev.off()
                 })
            }

# Run the application
shinyApp(ui = ui, server = server)


print(paste0(Sys.time(), " --- Catch per effort graph"))

species_and_pub_per_year <- df_publications_N[, list(species_per_publication=mean(n_species),
                                            N_publications=length(n_species),
                                            N_species=sum(n_species)), by="date.n"][order(date.n)]
rng <- range(species_and_pub_per_year$date.n)
species_and_pub_per_year <-
    data.table(merge(data.frame(date.n=seq(rng[1], rng[2])),
                     species_and_pub_per_year,
                     by="date.n", all.x=T, all.y=F))
species_and_pub_per_year[is.na(species_and_pub_per_year)] <- 0

species_and_pub_per_year$species_per_publication_roll <-
    rollmean(species_and_pub_per_year$species_per_publication, 10,
             fill = list(NA, NULL, NA))

p5 <- ggplot(species_and_pub_per_year, aes(x=date.n, y=species_per_publication)) +
    xlab("") + ylab("Number of species/ publication") +
    theme +
    ggtitle("") +
    # ggtitle("Number of species/ publication by year") +
    geom_point(size=1, color='grey') +
    geom_line(size=.5, color='grey', linetype='dashed') +
    geom_smooth(fill=NA, color='black', size=1.5) +
    geom_line(size=1, aes(y=species_per_publication_roll), color='grey50') +
    scale_x_continuous(breaks=ybreaks50, minor_breaks=ybreaks10) +
    scale_y_continuous(breaks=ybreaks20, minor_breaks=ybreaks5)

bp_year = 1907; y=4.1
# y = taxonomic_effort[which(years==bp_year)]$species_per_real_taxonomist
p13 <- ggplot(data=taxonomic_effort, aes(x=years, y=species_per_real_taxonomist)) +
    xlab("Year") + ylab("Number of species/ PTE") +
    ggtitle("") +
    # ggtitle("Number of species described/ PTE by year") +
    theme +
    geom_point(size=1, color='grey') +
    geom_line(size=.5, color='grey', linetype='dashed') +
    geom_smooth(fill=NA, color='black', size=1.5) +
    geom_line(size=1, aes(y=species_per_real_taxonomist_roll), color='grey50') +
    annotate(geom='curve', x=bp_year+30, y=round(y+4,0), xend=bp_year, yend=y,
             curvature=.1, arrow=arrow(length=unit(1, 'mm')), size=1, color='red') +
    annotate(geom='text', hjust='left', x=bp_year+33, y=round(y+4,0)+.2,
             label='Break point', size=4, color='red') +
    scale_x_continuous(breaks=ybreaks50, minor_breaks=ybreaks10) +
    scale_y_continuous(breaks=ybreaks2, minor_breaks=ybreaks1, limits=c(0,12))

p16 <- ggplot(data=taxonomic_effort, aes(x=years, y=species_per_real_taxonomist_weighted)) +
    xlab("Year") + ylab("Number of species \ndescribed/ PTE \n(wted)") + theme +
    # ggtitle("Number of species described/ PTE (wted) by year") +
    ggtitle("") +
    geom_point(size=1, color='grey') +
    geom_line(size=.5, color='grey', linetype='dashed') +
    geom_smooth(fill=NA, color='black', size=1.5) +
    geom_line(size=1, aes(y=species_per_real_taxonomist_weighted_roll), color='grey50') +
    scale_x_continuous(breaks=ybreaks50, minor_breaks=ybreaks10) +
    scale_y_continuous(breaks=ybreaks2, minor_breaks=ybreaks1, limits=c(0,12))

ggsave(paste0(dir_plot, 'fig-5a.png'), p5, units="cm", width=18, height=5, dpi=300)
ggsave(paste0(dir_plot, 'fig-5b.png'), p13, units="cm", width=18, height=5, dpi=300)
ggsave(paste0(dir_plot, 'fig-5c.png'), p16, units="cm", width=18, height=5, dpi=300)

# Trend analysis

# species_and_pub_per_year$species_per_publication
# taxonomic_effort$species_per_real_taxonomist

ts_data_sp_per_pub <- ts(species_and_pub_per_year$species_per_publication,
                         frequency = 1, start = c(1758))
ts_data_species_per_tax <- ts(taxonomic_effort$species_per_real_taxonomist,
                              frequency = 1, start = c(1758))

ts_data <- ts_data_species_per_tax

adf.test(ts_data)
kpss.test(ts_data)
nsdiffs(ts_data)

idx_1910 <- which(species_and_pub_per_year$date.n == 1907)

res <- MannKendall(ts_data_sp_per_pub)
summary(res)
res <- MannKendall(ts_data_species_per_tax[1:idx_1910])
summary(res)
res <- MannKendall(ts_data_species_per_tax[idx_1910:length(ts_data_species_per_tax)])
summary(res)

# Breakpoint analysis
# Resource:
# https://rpubs.com/MarkusLoew/12164
taxonomic_effort$roll <- rollmean(taxonomic_effort$species_per_real_taxonomist, 10,
                                  fill = list(NA, NULL, NA))
plot(taxonomic_effort$years, taxonomic_effort$ma)
mod <- lm(species_per_real_taxonomist~years, data = taxonomic_effort)
seg <- segmented(mod, seg.Z = ~ years, psi = list(years=1910))

mod <- lm(ma~years, data = taxonomic_effort[!is.na(ma)])
seg <- segmented(mod, seg.Z = ~ years, psi = list(years=1910))

summary(seg)
seg$psi

# https://otexts.com/fpp2/moving-averages.html
# https://otexts.com/fpp2/stationarity.html


library(EpiEstim)
library(tidyverse)
library(lubridate)
library(fpp2)

reported_cases <- read_csv("E:\\Pythonfiles\\Github_Programs\\EstmatingRtDeepL\\Rt_Methods_Comparision\\ontario_cases.csv")
reported_cases$date <- ymd(reported_cases$date)
head(reported_cases)

dailycase <- ma(reported_cases$confirm,5)
dailycase[1:2] = c(0.8,0.8)
dailycase[149:150] =c(166.6,166.6)

I <- c(0)
for (k in 1:(length(reported_cases$confirm)-1)){
  I[k+1] = 0.9*I[k] + dailycase[k]
}

Rt <- c(0)
for (k in 1:(length(reported_cases$confirm)-1)){
  Rt[k+1] = 10*(I[k+1]-I[k])/I[k] + 1
}
Rt <- as.data.frame(Rt)

write_csv(Rt, "ontario_kalmanfilter_Rt.csv")


#'Compute predictive value of MC cover as correlation of weighted MC averages of sc umis
#'
#'@param mc_id id of metacells to analyze
#'@param mat_id umi matrix
#'@param do_log should log transofmration be performed
#'@param focus_cells should correltion be computed to a specific set of cells
#'
mcell_wgtmc_pred_corr = function(mc_id, mat_id, graph_id, do_log = F, focus_cells=NULL)
{
	old_seed = .set_seed(get_param("mc_rseed"))

	mc = scdb_mc(mc_id)
	if(is.null(mc)) {
		stop("MC-ERR: mc id ", mc_id, " is missing when compute mc prediction QC")
	}
	mat = scdb_mat(mat_id)
	if(is.null(mat)) {
		stop("MC-ERR: mat id ", mat_id, " is missing when computing mc prediction QC")
	}
	graph = scdb_cgraph(graph_id)
	if(is.null(graph)) {
		stop("MC-ERR: cell graph id ", graph_id, " is missing computing graph prediction QC")
	}

	umis = mat@mat

	csize = colSums(umis)
	n_downsamp = quantile(csize,0.05)
	umis_ds = scm_downsamp(umis, n_downsamp)

	f = rowSums(umis_ds) > 100	#just to save comp time
	umis = umis[f,]
	umis_ds = umis_ds[f,]
	if(do_log) {
		stat = Matrix(log2(1+ 7*umis_ds))
	} else {
		stat = umis_ds
	}

	mc_im = diag(max(mc@mc))[mc@mc,]
	rownames(mc_im) = names(mc@mc)

	mc_key = mc@mc[levels(graph@edges$mc2)]
	targ_mc = mc_key[graph@edges$mc2]
	neigh_im = as.matrix(table(graph@edges$mc1, targ_mc))
	neigh_im = neigh_im/rowSums(neigh_im)
	neigh_im1 = matrix(neigh_im, nrow=nrow(neigh_im))
	rownames(neigh_im1) = rownames(neigh_im)

	nfolds = 20

	all_cells = intersect(colnames(stat), names(mc@mc))
	folds = sample((1:nfolds),size=length(all_cells), rep=T)

	preds = c()

	for(fi in 1:nfolds) {
		#compute mc stats
		c_test = all_cells[folds == fi]
		c_train = all_cells[folds != fi]
		mcf_im =  mc_im[c_train,]
		mcf_im = t(t(mcf_im)/colSums(mcf_im))
		u_gm = stat[,c_train] %*% mcf_im
		pred_ig = neigh_im1[c_test,] %*% t(u_gm)
		if(is.null(preds)) {
			preds = t(pred_ig)
		} else {
			preds = cbind(preds, t(pred_ig))
		}
	}
#	save(preds, stat, file="mc_preds.Rda")
	preds = preds[,colSums(is.na(preds))==0]  #ignoring rare case of 0 connectivity within the train set
	pcor = allrow_cor(stat[,colnames(preds)], preds)

	.restore_seed(old_seed)

	return(pcor)
}


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

#                          tttt            iiii  lllllll
#                       ttt:::t           i::::i l:::::l
#                       t:::::t            iiii  l:::::l
#                       t:::::t                  l:::::l
# uuuuuu    uuuuuuttttttt:::::ttttttt    iiiiiii  l::::l     ssssssssss
# u::::u    u::::ut:::::::::::::::::t    i:::::i  l::::l   ss::::::::::s
# u::::u    u::::ut:::::::::::::::::t     i::::i  l::::l ss:::::::::::::s
# u::::u    u::::utttttt:::::::tttttt     i::::i  l::::l s::::::ssss:::::s
# u::::u    u::::u      t:::::t           i::::i  l::::l  s:::::s  ssssss
# u::::u    u::::u      t:::::t           i::::i  l::::l    s::::::s
# u::::u    u::::u      t:::::t           i::::i  l::::l       s::::::s
# u:::::uuuu:::::u      t:::::t    tttttt i::::i  l::::l ssssss   s:::::s
# u:::::::::::::::uu    t::::::tttt:::::ti::::::il::::::ls:::::ssss::::::s
#  u:::::::::::::::u    tt::::::::::::::ti::::::il::::::ls::::::::::::::s
#   uu::::::::uu:::u      tt:::::::::::tti::::::il::::::l s:::::::::::ss
#     uuuuuuuu  uuuu        ttttttttttt  iiiiiiiillllllll  sssssssssss

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

# # # backprop
# backpropagate error and update weights
#  #  #  #  #  #  #  #  #  #  #  #  #  #  #  #  #  #  #  #  #  #  #  #  #  #  #
backprop <- function(out_wts, in_wts, out_activation, current_target,
                     hid_activation, hid_activation_raw, ins_w_bias, learning_rate){

  # # # calc error on output units
  out_delta <- 2 * (out_activation - current_target)

  # # # calc error on hidden units
  hid_delta <- out_delta %*% t(out_wts)
  hid_delta <- hid_delta[,2:ncol(hid_delta)] * sigmoid_grad(hid_activation_raw)

  # # # calc weight changes
  out_delta <- learning_rate * (t(hid_activation) %*% out_delta)
  hid_delta <- learning_rate * (t(ins_w_bias) %*% hid_delta)

  # # # adjust wts
  out_wts <- out_wts - out_delta
  in_wts <- in_wts - hid_delta

  return(list(out_wts = out_wts,
              in_wts  = in_wts))

}

# # # forward_pass
# conduct forward pass
#  #  #  #  #  #  #  #  #  #  #  #  #  #  #  #  #  #  #  #  #  #  #  #  #  #  #
forward_pass <- function(in_wts, out_wts, inputs, out_rule) {
  # # # init needed vars
  num_feats <- ncol(out_wts)
  num_cats  <- dim(out_wts)[3]
  num_stims <- nrow(inputs)
  if (is.null(num_stims)) {num_stims <- 1}

  # # # add bias to ins
  bias_units <- matrix(rep(1, num_stims), ncol = 1, nrow = num_stims)
  ins_w_bias <- cbind(bias_units,
    matrix(inputs, nrow = num_stims, ncol = num_feats, byrow = TRUE))

  # # # ins to hids propagation
  hid_activation_raw <- ins_w_bias %*% in_wts
  hid_activation <- sigmoid(hid_activation_raw)

  # # # add bias unit to hid activation
  hid_activation <- cbind(bias_units, hid_activation)

  # # # hids to outs propagation
  out_activation <- array(rep(0, (num_stims * num_feats * num_cats)),
    dim = c(num_stims, num_feats, num_cats))

  # # NEED VECTORIZED HERE?
  # # # get output activation
  for (category in 1:num_cats) {
  	out_activation[,,category] <- hid_activation %*% out_wts[,,category]
  }

  # # # apply output activatio rule
  if(out_rule == 'sigmoid') {
  	out_activation <- sigmoid(out_activation)
  }

  return(list(out_activation     = out_activation,
              hid_activation     = hid_activation,
              hid_activation_raw = hid_activation_raw,
              ins_w_bias         = ins_w_bias))

}

# # # get_wts
# generate net weights
#  #  #  #  #  #  #  #  #  #  #  #  #  #  #  #  #  #  #  #  #  #  #  #  #  #  #
get_wts <- function(num_feats, num_hids, num_cats, wts_range, wts_center) {
  # # # set bias
  bias <- 1

  # # # generate wts between ins and hids
  in_wts <-
    (matrix(runif((num_feats + bias) * num_hids), ncol = num_hids) - 0.5) * 2
  in_wts <- wts_center + (wts_range * in_wts)

  # # # generate wts between hids and outs
  out_wts <-
    (array(runif((num_hids + bias) * num_feats * num_cats),
      dim = c((num_hids + bias), num_feats, num_cats)) - 0.5) * 2
  out_wts <- wts_center + (wts_range * out_wts)

  return(list(in_wts  = in_wts,
              out_wts = out_wts))

}

# # # global_scale
# scale inputs to 0/1
#  #  #  #  #  #  #  #  #  #  #  #  #  #  #  #  #  #  #  #  #  #  #  #  #  #  #
global_scale <- function(x) { x / 2 + 0.5 }

# # # train_plot
# function to produce line plot of training
#  #  #  #  #  #  #  #  #  #  #  #  #  #  #  #  #  #  #  #  #  #  #  #  #  #  #
train_plot <- function(training) {
  # # # get dimensions
  n_cats <- dim(training)[2]
  xrange <- c(1, dim(training)[1])
  yrange <- range(training)

  # # # open plot device
  pdf('training_plot.pdf')

  # # # create frame
  plot(xrange, c(.01, yrange[2]), xlab = 'Block Number', ylab = 'Accuracy')

  # # # aesthetics
  colors <- rainbow(n_cats)
  line_type <- c(1:n_cats)
  plot_char <- seq(18, 18 + n_cats, 1)

  # # # plot lines
  for (i in 1:n_cats) {
    target_cat <- training[,i]
    lines(seq(1, xrange[2], 1), target_cat, type = 'b', lwd = 1.5,
      lty = line_type[i], col = colors[i],  pch = plot_char[i])
  }

  # # # title and legend
  title('DIVA Training Accuracy across Blocks')
  legend('bottomright', y = NULL, 1:n_cats, cex = 0.8, col = colors,
    pch = plot_char, lty = line_type, title = 'SHJ Categories')

  # # # produce plot
  dev.off()

}

# response_rule
# convert output activations to classification
#  #  #  #  #  #  #  #  #  #  #  #  #  #  #  #  #  #  #  #  #  #  #  #  #  #  #
response_rule <- function(out_activation, target_activation, beta_val){
  num_feats <- ncol(out_activation)
  num_cats  <- dim(out_activation)[3]
  num_stims <- nrow(target_activation)
  if (is.null(num_stims)) {num_stims <- 1}

  # # # calc error
  ssqerror <- array(as.vector(
    apply(out_activation, 3, function(x) {x - target_activation})),
      c(num_stims, num_feats, num_cats))
  ssqerror <- ssqerror ^ 2
  ssqerror[ssqerror < 1e-7] <- 1e-7

  # # # if focusing is on:
  if (beta_val > 0) {
    # # # get list of channel comparisons
    pairwise_comps <- combn(1:num_cats, 2)

    # # # get differences for each feature between categories
    diff_matrix <-
      abs(apply(pairwise_comps, 2, function(x) {
        out_activation[,,x[1]] - out_activation[,,x[2]]}))

    # # # reconstruct activation array and get feature diversity means
    diff_array <- array(diff_matrix, dim = c(num_stims, num_feats, num_cats))
    feature_diffs <- apply(diff_array, 2, mean)

    # # # calculate diversities
    diversities <- exp(beta_val * feature_diffs)
    diversities[diversities > 1e+7] <- 1e+7

    # # # divide diversities by sum of diversities
    fweights = diversities / sum(diversities)

    # # # apply focus weights; then get sum for each category
    ssqerror <- t(apply(ssqerror, 3, function(x) sum(x * fweights)))

  # # # otherwise, set focus weights to NULL
  } else {
    fweights <- NULL
  }

  # # # calculate inverse sse
  ssqerror <- 1 / ssqerror

return(list(ps       = (ssqerror / sum(ssqerror)),
            fweights = fweights,
            ssqerror = ssqerror))

}

# run_diva
# trains vanilla diva
#  #  #  #  #  #  #  #  #  #  #  #  #  #  #  #  #  #  #  #  #  #  #  #  #  #  #
run_diva <- function(model) {

  # # # get new seed
  model.seed <- runif(1) * 100000 * runif(1)
  set.seed(model.seed)

  # # # set mean value of weights
  model$wts_center <- 0
  # # # convert targets to 0/1
  model$targets <- global_scale(model$inputs)
  # # # init size parameter variables
  model$num_feats   <- ncol(model$inputs)
  model$num_stims   <- nrow(model$inputs)
  model$num_cats    <- length(unique(model$labels))
  model$num_updates <- model$num_blocks * model$num_stims
  # # # init training accuracy matrix
  training <-
    matrix(rep(NA, model$num_updates * model$num_inits),
      nrow = model$num_updates, ncol = model$num_inits)

  # # # initialize and run DIVA models
  for (model_num in 1:model$num_inits) {

    # # # generate weights
    wts <- get_wts(model$num_feats, model$num_hids, model$num_cats,
      model$wts_range, model$wts_center)

    # # # generate random presentation order
    prez_order <- as.vector(apply(replicate(model$num_blocks,
      seq(1, model$num_stims)), 2, sample, model$num_stims))

    # # # iterate over each trial in the presentation order
    for (trial_num in 1:model$num_updates) {
      current_input  <- model$inputs[prez_order[[trial_num]], ]
      current_target <- model$targets[prez_order[[trial_num]], ]
      current_class  <- model$labels[prez_order[[trial_num]]]

      # # # complete forward pass
      fp <- forward_pass(wts$in_wts, wts$out_wts, current_input, model$out_rule)

      # # # calculate classification probability
      response <- response_rule(fp$out_activation, current_target, model$beta_val)

      # # # store classification accuracy
      training[trial_num, model_num] = response$ps[current_class]

      # # # back propagate error to adjust weights
      class_wts <- wts$out_wts[,,current_class]
      class_activation <- fp$out_activation[,,current_class]

      adjusted_wts <- backprop(class_wts, wts$in_wts, class_activation, current_target,
               fp$hid_activation, fp$hid_activation_raw, fp$ins_w_bias, model$learning_rate)

      # # # set new weights
      wts$out_wts[,,current_class] <- adjusted_wts$out_wts
      wts$in_wts <- adjusted_wts$in_wts

    }

  }

training_means <-
  rowMeans(matrix(rowMeans(training), nrow = model$num_blocks, ncol = model$num_stims, byrow = TRUE))

return(list(training = training_means,
            model    = model))

}

# shj_cats
# loads shj category structures
#  #  #  #  #  #  #  #  #  #  #  #  #  #  #  #  #  #  #  #  #  #  #  #  #  #  #
demo_cats <- function(type){

  in_pattern <-
    matrix(c(-1, -1, -1,
	           -1, -1,  1,
	           -1,  1, -1,
  	         -1,  1,  1,
	            1, -1, -1,
	            1, -1,  1,
	            1,  1, -1,
	            1,  1,  1),
      nrow = 8, ncol = 3, byrow = TRUE)

  cat_assignment <-
    matrix(c(1, 1, 1, 1, 2, 2, 2, 2,  # type I
             1, 1, 2, 2, 2, 2, 1, 1,  # type II
             1, 1, 2, 1, 1, 2, 2, 2,  # type III
             1, 1, 1, 2, 1, 2, 2, 2,  # type IV
             2, 1, 1, 1, 1, 2, 2, 2,  # type V
             1, 2, 2, 1, 2, 1, 1, 2,  # type VI
             1, 1, 2, 2, 3, 3, 4, 4), # type II multiclass
      ncol = 8, byrow = TRUE)

return(list(inputs = in_pattern,
			      labels = cat_assignment[type,]))

}

# sigmoid
# returns sigmoid evaluated elementwize in X
#  #  #  #  #  #  #  #  #  #  #  #  #  #  #  #  #  #  #  #  #  #  #  #  #  #  #
sigmoid <- function(x) {
  g = 1 / (1 + exp(-x))

return(g)

}

# sigmoid gradient
# returns the gradient of the sigmoid function evaluated at x
#  #  #  #  #  #  #  #  #  #  #  #  #  #  #  #  #  #  #  #  #  #  #  #  #  #  #
sigmoid_grad <- function(x) {

return(g = ((sigmoid(x)) * (1 - sigmoid(x))))

}


# allocativ
# Healthy Neighborhoods
# ACS DP5Y2018 join Code
# FIPS sum, avg, gini code

### Import Hadley Wickham Libraries
library(tidyverse) # All of the libraries above in one line of code

### Import Statistics Libraries
library(ineq) # Gini coefficient and Lorenz curve
library(pROC) # ROC tests with AUC output

### Set wd
setwd("C:/Users/drewc/GitHub/allocativ") # Set wd to project repository

### Import data
df_doh = read.csv("hnb/DOH/FL/113_5Y2018/FL_113_ZCTA.csv") # Import dataset from _data folder
df_key = read.csv("hnb/FIPS/FIPS_ZCTA_key.csv") # Import dataset from _data folder

### Join with key
df_key = subset(df_key, select = c(FIPS, ZCTA)) # Remove variables with high missing values
df_join = inner_join(df_key, df_doh, by = "ZCTA") ## Join By Columns

### Clean Data
df_join[is.na(df_join)] <- 0 # Convert all NA to 0

### Convert all to numeric
df_num = subset(df_join, select = -c(FIPS, ZCTA, PERCENT_TOTAL, POPULATION)) # Remove columns in dataframe
df_num = df_num %>% mutate_if(is.character, as.numeric) ## Change Characters to Numeric
df_num$FIPS = df_join$FIPS

### Gini, Avg
tib_FIPS = df_num %>% group_by(FIPS) %>% summarise_all(.funs = list(gini = ~ ineq(x = ., type = "Gini"), avg = ~ mean(x = .))) # Group By Columns and Average
df_FIPS = as.data.frame(tib_FIPS) # Convert tiblle to Data Frame

### Export to CSV
write.csv(df_FIPS, "hnb/DOH/FL/113_5Y2018/FL_113_FIPS_gini.csv", row.names = FALSE)


rm(list = ls()) # This clears everything from memory.

setwd("~/Dropbox/BCI_Turnover")
load("BCI_turnover20141213.RData")
library(dplyr)
ab_data <- as.data.frame(sapply(D20m,function(x)apply(x,2,sum)))
ab_data$sp <- rownames(ab_data)

trait.temp <- data.frame(sp=rownames(trait),
  moist=trait$Moist,
  slope=trait$sp.slope.mean,
  slope.sd = trait$sp.slope.sd,
  convex=trait$sp.convex.mean,
  convex.sd=trait$sp.convex.sd,
  WSG=trait$WSG)

ab_t_data <- merge(ab_data,trait.temp,by="sp")

ab_t_data2 <- na.omit(ab_t_data)

# temp.data<-D[D$status1=="A",]

ab_t_data2$inc <- as.factor(ifelse(ab_t_data2$census_2010>ab_t_data2$census_1982,"UP","Down"))

# plot(convex~inc,data=ab.t.data2)
library(MASS)

ab_t_data2 <- ab_t_data %>%
  na.omit() %>%
  filter(census_1982 != 0 | census_2010 != 0) %>%
  mutate(census_1982 = census_1982 + 1) %>%
  mutate(census_2010 = census_2010 + 1) %>%
  mutate(WSG_moist = as.numeric(scale(WSG*moist))) %>%
  mutate(WSG_slope = as.numeric(scale(WSG*slope))) %>%
  mutate(WSG_convex = as.numeric(scale(WSG*convex))) %>%
  mutate(slope_moist = as.numeric(scale(slope*moist))) %>%
  mutate(convex_moist = as.numeric(scale(convex*moist))) %>%
  mutate(slope_convex = as.numeric(scale(slope*convex))) %>%
  mutate(WSG = as.numeric(scale(WSG))) %>%
  mutate(slope = as.numeric(scale(slope))) %>%
  mutate(convex = as.numeric(scale(convex))) %>%
  mutate(moist = as.numeric(scale(moist)))

r2.func = function(res, data){
  y = data$census_2010/data$census_1982
  residuals = y - res$fitted.values/data$census_1982
  1 - sum(residuals^2) / sum((y - mean(y))^2)
}

res2 <- glm.nb(census_2010 ~ WSG
            + moist
            + convex
            + slope
            + WSG_moist
            + WSG_convex
            + WSG_slope
            + slope_convex
            + slope_moist
            + convex:moist
            + offset(log(census_1982)),
            data = ab_t_data2)

summary(res2)
r2.func(res2, data = ab_t_data2)

res3 <- glm.nb(census_2010 ~WSG
            + moist
            + convex
            + slope
            + WSG:moist
            + WSG:convex
            + WSG:slope
            + convex:slope
            + moist:slope
            + convex:moist
            + WSG:convex:slope
            + WSG:moist:slope
            + WSG:convex:moist
            + slope:convex:moist
            + offset(log(census_1982)),
            data = ab_t_data2)

stepAIC(res2)

res_tr <- glm.nb(census_2010 ~ WSG
            + moist
            + convex
            + slope
            + WSG:slope
            + convex:moist
            + offset(log(census_1982)),
            data = ab_t_data2)

summary(res_tr)
r2_obs <- r2.func(res_tr, data = ab_t_data2)

1 - (1 - r2_obs) * (nrow(ab_t_data2) - 1) / (nrow(ab_t_data2) - 6 - 1)

r2_func <- function(res, data){
  # data <- ab_t_data2[ab_t_data2$ab1982 >= n, ]
  y <- data$census_2010/data$census_1982
  residuals <- y - res$fitted/data$census_1982
  # residuals = y - exp(res$linear.predictors)/data$census_1982
  1 - sum(residuals^2) / sum((y - mean(y))^2)
}

r2_func(res_tr, ab_t_data2)

data <- moge

r2.func(res_all, data = ab_t_data2)

temp <- c("WSG", "moist", "slope", "convex")
moge2 <- NULL
moge3 <- NULL
before <- proc.time()
for (j in 1:4){
  moge <- ab_t_data2
  for (i in 1:99){
    moge[, temp[j]] <- sample(moge[, temp[j]])
    res <- glm.nb(census_2010 ~WSG
                + moist
                + convex
                + slope
                + WSG:slope
                + convex:moist
                + offset(log(census_1982)),
                data = moge)
    moge2[i] <- r2.func(res, data = moge)
  }
  moge3 <- cbind(moge2, moge3)
}

after <- proc.time()
after - before

obs_rank <- apply(rbind(r2_obs, moge3), 2, rank)[1,]
(1 - (obs_rank /100)) * 2 # one tail

moge2 <- NULL
for (i in 1:99){
  moge <- ab_t_data2
  moge$WSG <- sample(moge$WSG)
  moge$moist <- sample(moge$moist)
  moge$convex <- sample(moge$convex)
  moge$slope <- sample(moge$slope)
  res <- glm.nb(census_2010 ~WSG
              + moist
              + convex
              + slope
              + WSG:slope
              + convex:moist
              + offset(log(census_1982)),
              data = moge)
  moge2[i] <- r2.func(res, data = moge)
}
c(r2_obs,moge2) %>% rank

moge2 <- NULL

for (i in 1:99){
  temp1 <- ab_t_data2 %>%
    dplyr::select(sp, census_1982, census_2010)
  temp2 <- ab_t_data2 %>%
    dplyr::select(sp, WSG, moist, convex, slope)

  temp1$sp <- sample(temp1$sp) %>% as.character

  moge <- full_join(temp1, temp2, by = "sp")
  # moge <- ab_t_data2
  # moge$WSG <- sample(moge$WSG)
  # moge$moist <- sample(moge$moist)
  # moge$convex <- sample(moge$convex)
  # moge$slope <- sample(moge$slope)
  res <- glm.nb(census_2010 ~WSG
              + moist
              + convex
              + slope
              + WSG:moist
              + WSG:convex
              + WSG:slope
              + convex:slope
              + moist:slope
              + convex:moist
              + offset(log(census_1982)),
              data = moge)
  moge2[i] <- r2.func(res, data = moge)
}

c(r2_obs,moge2) %>% rank

res <- glm.nb(census_2010 ~WSG
            + offset(log(census_1982)),
            data = moge)


look.and.say <- function(x, return.an.int=FALSE)
{
   #convert number to character vector
   xstr <- unlist(strsplit(as.character(x), ""))
   #get run length encoding
   rlex <- rle(xstr)
   #form new string
   odds <- as.character(rlex$lengths)
   evens <- rlex$values
   newstr <- as.vector(rbind(odds, evens))
   #collapse to scalar
   newstr <- paste(newstr, collapse="")
   #convert to number, if desired
   if(return.an.int) as.integer(newstr) else newstr
}


source("pattern_to_number.r")

computing_frequencies <- function(text, k) {
  frequency_array <- array(0, 4^k)
  for(i in 0:(nchar(text) - k)) {
    pattern <- substr(text, i + 1, i + k)
    j <- pattern_to_number(pattern)
    frequency_array[j + 1] <- frequency_array[j + 1] + 1
  }
  return(frequency_array)
}

# message("Text")
# text <- scan("stdin", what="character", nlines=1)
# message("k")
# k <- scan("stdin", nlines=1)
#
# cat(computing_frequencies(text, k))


#rm(list= ls())
library(changepoint)
library(ggplot2)
library(dplyr)
#source("C:/Users/anthony/Desktop/my_project/census-app/helpers.R")
library(shiny)

#air_data <- readRDS("data/Air_box.rds")
load(file = "data/May_Airbox.RData")
sensor_ID <- unique(air_data$ID)
select_id <- as.character(sensor_ID)
names(select_id) = as.character(sensor_ID)

ui <- fluidPage(
	#input
	fluidRow(
		column(4,
			selectInput(inputId = "cur_sen_box",
					  label = "Sensor_ID",
					  choices = select_id,
					  selected = "28C2DDDD41C0"
					  )
		  ),
		column(4,
			dateRangeInput(inputId = "date_range",
						  label = "Choose the range of date",
						  start = "2016-05-01",
						  end = "2016-05-01",
						  min = "2016-05-01",
						  max = "2016-05-31",
						  format = "mm/dd/yy",
						  separator = " to "
						  )
		)
	),
	fluidRow(
		  column(4,
			    radioButtons(inputId = "ch_method",
				    label = "Method",
				    choices = c( "LEVEL" = "LEVEL", "PELT" = "PELT", "SegNeigh" = "SegNeigh", "BinSeg" = "BinSeg", "Best" = "Best"),
				    selected = "Best"
			    )
		  ),
		  column(4,
		        numericInput(inputId = "Bin_t",
		          label = "Change times (only for SegNeigh and Best)",
		          value = 7,
		          min = 1,
		          max = 31
		        ),
		        actionButton(inputId = "submit",
		                     label = "Cpt Detect"
		                     )
		  ),
		  column(4,
		         radioButtons(inputId = "display_method",
		                      label = "Display",
		                      choices = c( "Vertical" = "Vertical", "Horizontal" = "Horizontal"),
		                      selected = "Horizontal"
		         )
		  )

	),

	plotOutput("PM25_Graph"),
	verbatimTextOutput("act_days")
)

server <- function(input, output) {

	#------------------ reactive -----------------#
	PM25_of_sensor <- reactive({
		subset(air_data, ID == input$cur_sen_box)
    })
	plot_fig <- reactive({

	  PM25_of_sensor()[
	    which((as.numeric(as.Date(PM25_of_sensor()$f_time, tz = "Etc/GMT+8")) >= as.numeric(input$date_range[1])
	          & as.numeric(as.Date(PM25_of_sensor()$f_time, tz = "Etc/GMT+8")) <= as.numeric(input$date_range[2])))
	    ,]
	})
	#----------------event reactive--------------------#
	change_time <- eventReactive( input$submit,{
	  switch(input$ch_method,
	         #------------------ New Visualization -----------------#
	         LEVEL = {
	           line_color = character (length(plot_fig()$PM25))
	           line_color[which(plot_fig()$PM25 >= 71)] = "#9900FF" #Purple

	           line_color[which(plot_fig()$PM25 <  71)] = "#990000" #Dark Red
	           line_color[which(plot_fig()$PM25 <  65)] = "#FF0000" #Red
	           line_color[which(plot_fig()$PM25 <  59)] = "#FF9999" #Light Red

	           line_color[which(plot_fig()$PM25 <  54)] = "#FF6600" #Orange
	           line_color[which(plot_fig()$PM25 <  48)] = "#FFCC00" #Tangerine
	           line_color[which(plot_fig()$PM25 <  42)] = "#FFFF00" #Yellow

	           line_color[which(plot_fig()$PM25 <  36)] = "#336600" #Dark Green
	           line_color[which(plot_fig()$PM25 <  24)] = "#00FF00" #Green
	           line_color[which(plot_fig()$PM25 <  12)] = "#CCFF99" #Light Green

	           line_color

	           },
	         #------------------- Changepoint Method ----------------------#
	         PELT = {ifelse(length( cpts( cpt.meanvar(plot_fig()$PM25, method = "PELT") ) ) == 0, NA, list( cpts( cpt.meanvar(plot_fig()$PM25, method = "PELT") ) ))},
	         SegNeigh = {
				      temp <- cpt.meanvar(plot_fig()$PM25,penalty="Asymptotic",pen.value=0.01,method="SegNeigh",Q = input$Bin_t ,class=FALSE)
				      ifelse(length(temp) == 0, NA, list(temp))},
	         BinSeg = {
				      temp <- cpt.meanvar(plot_fig()$PM25,penalty="Manual",pen.value="4*log(n)",method="BinSeg",Q = input$Bin_t,class=FALSE)
				      ifelse(length(temp) == 0, NA, list(temp))},
    			 Best = {
    			   temp <- cpt.meanvar(plot_fig()$PM25, pen.value = c(4,1500), penalty = "CROPS", method = "PELT")
    			   crop_matrix <- cpts.full(temp)
    			   crop_index <-crop_matrix[ nrow(crop_matrix) - input$Bin_t,]
    			   list(crop_index <- crop_index[!is.na(crop_index)])
    			 }
	  )
	})
	#----------------- output -------------------#
	output$act_days <- renderPrint({
	  if(input$submit){
  	    if(input$ch_method == "LEVEL"){
  	        list(
      	        total_data_count = length(PM25_of_sensor()$PM25),
      	        covered_Days  = unique(as.Date(PM25_of_sensor()$f_time, tz = "Etc/GMT+8"))
  	        )
  	    }else if(input$ch_method == "PELT" || input$ch_method == "SegNeigh" || input$ch_method == "BinSeg" || input$ch_method == "Best"){
  	      list(
  	        total_data_count = length(PM25_of_sensor()$PM25),
  	        covered_Days  = unique(as.Date(PM25_of_sensor()$f_time, tz = "Etc/GMT+8")),
  	        chtime = plot_fig()$f_time[ change_time()[[1]] ]
  	      )
  	    }
  	}else{
	    list(
	      total_data_count = length(PM25_of_sensor()$PM25),
	      covered_Days  = unique(as.Date(PM25_of_sensor()$f_time, tz = "Etc/GMT+8"))
	    )

	  }
	})
	#----------------------- Output Graph -------------------------#
	output$PM25_Graph <- renderPlot({
	  p <- ggplot(plot_fig(),
		       aes(x = as.POSIXct(f_time, tz = "Etc/GMT+8"), y = PM25)) +
	          geom_line()
	  if(input$submit){
	    if(input$ch_method == "LEVEL"){

	      #initialize
	      line_10 <- rep(NA, length(plot_fig()$PM25))
	      line_9  <- rep(NA, length(plot_fig()$PM25))
	      line_8  <- rep(NA, length(plot_fig()$PM25))
	      line_7  <- rep(NA, length(plot_fig()$PM25))
	      line_6  <- rep(NA, length(plot_fig()$PM25))
	      line_5  <- rep(NA, length(plot_fig()$PM25))
	      line_4  <- rep(NA, length(plot_fig()$PM25))
	      line_3  <- rep(NA, length(plot_fig()$PM25))
	      line_2  <- rep(NA, length(plot_fig()$PM25))
	      line_1  <- rep(NA, length(plot_fig()$PM25))

	      #assign
	      line_10[which(change_time() == "#9900FF")] <- 1
	      #line_10[which((which(change_time() == "#9900FF")+1) < length(change_time())) ] <- 1

	      line_9[which(change_time() == "#990000")] <- 1
	      #line_9[which((which(change_time() == "#990000")+1) < length(change_time())) ] <- 1
	      line_8[which(change_time() == "#FF0000")] <- 1
	      #line_8[which((which(change_time() == "#FF0000")+1) < length(change_time())) ] <- 1
	      line_7[which(change_time() == "#FF9999")] <- 1
	      #line_7[which((which(change_time() == "#FF9999")+1) < length(change_time())) ] <- 1

	      line_6[which(change_time() == "#FF6600")] <- 1
	      line_5[which(change_time() == "#FFCC00")] <- 1
	      line_4[which(change_time() == "#FFFF00")] <- 1

	      line_3[which(change_time() == "#336600")] <- 1
	      line_2[which(change_time() == "#00FF00")] <- 1
	      line_1[which(change_time() == "#CCFF99")] <- 1

	      #color and plot
	      p <- p + geom_line(aes(y = line_10), colour = "#9900FF", size=2) +
	           geom_line(aes(y = line_9), colour = "#990000", size=2) +
	           geom_line(aes(y = line_8), colour = "#FF0000", size=2) +
	           geom_line(aes(y = line_7), colour = "#FF9999", size=2) +
	           geom_line(aes(y = line_6), colour = "#FF6600", size=2) +
	           geom_line(aes(y = line_5), colour = "#FFCC00", size=2) +
	           geom_line(aes(y = line_4), colour = "#FFFF00", size=2) +
	           geom_line(aes(y = line_3), colour = "#336600", size=2) +
	           geom_line(aes(y = line_2), colour = "#00FF00", size=2) +
	           geom_line(aes(y = line_1), colour = "#CCFF99", size=2)

	    }else if(input$ch_method == "PELT" || input$ch_method == "BinSeg" || input$ch_method == "SegNeigh" || input$ch_method == "Best" ){
	      if(input$display_method == "Vertical"){
	        p <- p + geom_vline(xintercept = as.numeric(plot_fig()$f_time[ change_time()[[1]] ]), colour = "red")
	      }else if(input$display_method == "Horizontal" && (input$ch_method == "PELT" || input$ch_method == "Best")  ){
	        j <- 1
	        cpt_vec <- vector(mode="numeric", length=0)
	        cpt_vec_fill <-  vector(mode="numeric", length=0)
	        today_time <- as.POSIXct(plot_fig()$f_time, tz = "Etc/GMT+8")

	        for(i in change_time()[[1]]){
	          cpt_vec[j:i-1] <- mean(plot_fig()$PM25[j:i-1])
	          cpt_vec[i-1] <- NA

	          j <- i+1
	          #print(cpt_vec)
	        }
	        i <- length( plot_fig()$PM25 )
	        cpt_vec[j:i] <- mean(plot_fig()$PM25[j:i])
	        p <- p + geom_line(aes(today_time, cpt_vec,na.rm = TRUE), colour = "red")

	      }else if( input$display_method == "Horizontal" && (input$ch_method == "BinSeg" || input$ch_method == "SegNeigh") ){
	        j <- 1
	        cpt_vec <- vector(mode="numeric", length=0)
	        cpt_vec_fill <-  vector(mode="numeric", length=0)
	        today_time <- as.POSIXct(plot_fig()$f_time, tz = "Etc/GMT+8")

	        for(i in change_time()[[1]]){
	          cpt_vec[j:i-1] <- mean(plot_fig()$PM25[j:i-1])
	          cpt_vec[i-1] <- NA

	          j <- i+1
	          #print(cpt_vec)
	        }
	        i <- length( plot_fig()$PM25 ) - 1
	        cpt_vec[j:i] <- mean(plot_fig()$PM25[j:i])
	        p <- p + geom_line(aes(today_time, cpt_vec,na.rm = TRUE), colour = "red")
	      }
	    }
	    # else if(input$ch_method == "Best" ){
	    #   j <- 1
	    #   cpt_vec <- vector(mode="numeric", length=0)
	    #   cpt_vec_fill <-  vector(mode="numeric", length=0)
	    #   today_time <- as.POSIXct(plot_fig()$f_time, tz = "Etc/GMT+8")
	    #
	    #   for(i in change_time()[[1]]){
	    #     cpt_vec[j:i-1] <- mean(plot_fig()$PM25[j:i-1])
	    #     cpt_vec[i-1] <- NA
	    #
	    #     j <- i+1
	    #     #print(cpt_vec)
	    #   }
	    #   i <- length( plot_fig()$PM25 )
	    #   cpt_vec[j:i] <- mean(plot_fig()$PM25[j:i])
	    #   p <- p + geom_line(aes(today_time, cpt_vec,na.rm = TRUE), colour = "red")
	    #   #p <- p + geom_vline(xintercept = as.numeric(plot_fig()$f_time[ change_time()[[1]] ]), colour = "blue")
	    # }
	 }
	 print(p)

	 #plot(as.POSIXct(plot_fig()$f_time, tz = "Etc/GMT+8"), plot_fig()$PM25,type = "l")

	})
}

shinyApp(ui = ui, server = server)


library(argparse)
library(glue)
source("skpr_wrapper.r")

parser <- ArgumentParser(description='Explore DOE design sizing using these inputs')
parser$add_argument('-n', '--n_plots', type='integer',
                          default=4, help='Number of subplots.')
parser$add_argument('-s', '--plot_size', type='integer',
                          default=10, help='Size of each subplot.')
args <- parser$parse_args()

# easy to change factors
x_levels <- c(0, 1, 2, 3, 4)
y_levels <- c('y1', 'y2', 'y3', 'y4')

# hard to change factors
i_levels <- c(-1, 0, 1)
j_levels <- c('a', 'b', 'c')

# define the factor levels
candidate_set <- expand.grid(
    x = x_levels,
    y = y_levels,
    i = i_levels,
    j = j_levels
)

# remove any disallowed combinations
candidate_set <- subset(
    candidate_set,
    !(x %in% c(4) & i %in% c(-1)) &  # these could be more complicated
    !(y %in% c('y1') & j %in% c('a'))
)

# define the formulas that will be used
model_htc <- ~i + j
model_design <- ~i + j + x + y +
                 I(x^2) + I(x^3)
model_me <- ~i + j + x + y
model_tfi <- ~i + j + x + y +
              x:i + y:i
model_alias <- ~x:y + x:j + y:j

model <- list(
    htc = model_htc,
    me = model_me,
    tfi = model_tfi,
    design = model_design,
    alias = model_alias
)

generate_design(candidate_set, model, args$n_plots, args$plot_size)


topswops <- function(x){
  i <- 0
  while(x[1] != 1){
    first <- x[1]
    if(first == length(x)){
      x <- rev(x)
    } else{
      x <- c(x[first:1], x[(first+1):length(x)])
    }
    i <- i + 1
  }
  return(i)
}

library(iterpc)

result <- NULL

for(i in 1:10){
  I <- iterpc(i, labels = 1:i, ordered = T)
  A <- getall(I)
  A <- data.frame(A)
  A$flips <- apply(A, 1, topswops)
  result <- rbind(result, c(i, max(A$flips)))
}


#' Add Slack Variables
#'
#' From a coefficient matrix, add slack variables.
#'
#' This operation comes in two flavors, goverened by functions
#' \code{slack()} and \code{slackdir()}.  For the former, given a
#' coefficient matrix \code{A} and an index of rows \code{rows},
#' this will return the coefficient matrix with slack variables
#' added appropriately.  The latter does the same, but for
#' extreme direction problems; in particular, it adds the constraint
#' for the sum of the \code{d}'s.
#'
#' @param A
#' Coefficient matrix.
#' @param rows
#' Index of rows which are _not_ equality constraints.  If left blank,
#' all are assumed to be inequality constraints.
#'
#' @name slack
#' @rdname slack
#' @export
slack <- function(A, rows)
{
  if (missing(rows))
    rows <- 1:nrow(A)

  if (any(rows < 1) || any(rows > nrow(A)))
    stop("Argument 'rows' must be a vector of indices no less than 1 and no greater than the number of rows of matrix A")

  rows <- unique(sort(rows))
  I <- diag(1, length(rows))

  noslack <- setdiff(1:nrow(A), rows)
  if (length(noslack) > 0)
  {
    tmp <- matrix(0, nrow=nrow(A), ncol=ncol(I))
    tmp[rows, ] <- I
    tmp[noslack, ] <- 0

    I <- tmp
  }

  cbind(A, I)
}

#slack(A)
#slack(A, 1:3)

#' @rdname slack
#' @export
#' @export
slackdir <- function(A, rows)
{
  D <- slack(A=A, rows=rows)

  rbind(D, c(rep(1, ncol(A)), rep(0, ncol(D)-ncol(A))))
}


### Database Check

## libraries
library(tidyverse)
library(RColorBrewer)

## load data
chl <- read.csv("databasePublished//chl.csv")
lakeID <- read.csv("databasePublished//uniqueID.csv")

## functions
se <- function(x) sqrt(var(x)/length(x))

## plot distribution of Chl
ggplot(chl, aes(x=log(ChlValues))) + geom_density(fill="#9ACC7C") + xlab("Log transformed Chlorophyll a (mg/L)") + ylab("Frequency of observered values") +
  annotate("text", x=1, y=0.3, label=paste("minimum = 0 mg/L"), size=5) + ## min
  annotate("text", x=1, y=0.27, label=paste("maximum = ", round(max(chl$ChlValues),2), "mg/L"), size=5)  + ## max
  annotate("text", x=1, y=0.24, label=paste("median ± se = ",round(median(chl$ChlValues),3), "±", round(se(chl$ChlValues),5), "mg/L"), size=5) +theme(axis.text=element_text(size=12),
                                                                                axis.title=element_text(size=14,face="bold"))+ theme(panel.grid.major = element_blank(), panel.grid.minor = element_blank()) + xlim(-10,6)
## Map of Lakes

## define trophic levels
## based on Carlson, R.E. (1977) A trophic state index for lakes. Limnology and Oceanography. 22:2 361–369.
lakeChl <- merge(lakeID, chl, by="uniqueID")
lakeChl[,"TSI"] <- ifelse(lakeChl$ChlValues<0.0026, "1. Oligotrophic",
                          ifelse(lakeChl$ChlValues<0.02, "2. Mesotrophic",
                                 ifelse(lakeChl$ChlValues<0.056, "3. Eutrophic","4. Hypereutrophic")))

## plot out global distribution of lake chl
mp <- NULL
mapWorld <- borders("world", colour="gray50", fill="gray50") # create a layer of borders
mp <- ggplot() +   mapWorld

mp <- mp+ geom_point(data=lakeChl , aes(x=Lon, y=Lat, color=TSI),  size=2, alpha=0.5)  +
  theme(legend.position="right", text = element_text(size=10)) + scale_colour_brewer()
mp

## check values of other variables
chem <- read.csv("databasePublished//waterchem.csv")
lakechar <- read.csv("databasePublished//LakeChar.csv")

### check proportion of data with values
reported <- function(x){
  (length(x)-sum(is.na(x)))/length(x)*100
}

reported(chem$TP.value)
reported(lakechar$pH)


library(dslabs)
data(heights)
options(digits = 3) #report 3 significant digits for all answers

#Filters heights that are shorter than 68.3
x <- heights$height
y <- mean(x)
x <- c(heights$height>68.3)

#Filters heights for women that are shorter than 68.3
x <- heights$height
y <- mean(x)
x <- c(heights$height>68.3)
sum (x)
v <- heights$sex =="Female"&heights$height >68.3
sum(v)

#
x <- heights$height
y <- mean(x)
x <- c(heights$height>68.3)
sum (x)
v <- heights$sex =="Female"&heights$height >68.3
sum(v)
z <- heights$sex =="Female"
mean(z)

y <- which.min(heights$height)
heights$height[y]

w <- match(c(50), heights$height)
w

w <- heights$sex[1032]
#or
w <- heights$sex[50]

max(heights$height)

X<- 50:82

library(dslabs)
install.packages('dplyr',repos ='http://cran.us.r-project.org')
data(heights)

male <- heights$height[heights$sex=="Male"]
female <- heights$height[heights$sex=="Female"]

#Converts the height data to centimeters
ht_cm <- heights$height * 2.54

ht_cm[18]
mean(ht_cm)

z <- heights$sex =="Female"
mean(z) * 2.54

females <- (heights$sex =='Female')
mean(females)

mean(filter(females), na.rm = true)


library("car")  # load the 'car' package
data("Anscombe")  # load the data set
#?Anscombe  # read a description of the data
head(Anscombe)  # look at the first few lines of the data

# response = educational expenditure
# predictors: income, young age, urban

Xc = scale(Anscombe, center=TRUE, scale=TRUE)
str(Xc)

data_jags = as.list(data.frame(Xc))

library("rjags")

# edu likelyhood = normal dist, predict y given the mean calculated using the yuong, urban and income coefficents
# normal prior for income, young and urban coeficents with large 1m variance to reduce correlations
# prior on variance in an inverse gamma
mod_string = " model {
    for (i in 1:length(education)) {
        education[i] ~ dnorm(mu[i], prec)
        mu[i] = b[1]*income[i] + b[2]*young[i] + b[3]*urban[i]
    }

    for (i in 1:3) {
        b[i] ~ dexp(1.0)
    }

    prec ~ dgamma(1.0, 1.0)
    	## Initial guess of variance based on overall
    	## variance of education variable. Uses low prior
    	## effective sample size. Technically, this is not
    	## a true 'prior', but it is not very informative.
    sig2 = 1.0 / prec
    sig = sqrt(sig2)
} "

set.seed(72)
#data1_jags = list(y=dat$loginfant, n=nrow(dat), log_income=dat$logincome)

# choose to monitor standard dev
params = c("b", "sig")

inits = function() {
    inits = list("b"=rexp(3, 1.0), "prec"=rgamma(1,1.0,1.0))
}

# run the model with 3 chains each starting with inits1 params
mod = jags.model(textConnection(mod_string), data=data_jags, inits=inits, n.chains=3)

dic.samples(mod, n.iter=100e3)

# burn in period
update(mod, 1000)

mod_sim = coda.samples(model=mod, variable.names=params, n.iter=100e3)

# stack matrices vertically
mod_csim = do.call(rbind, mod_sim)

### Convergence
plot(mod_sim)
gelman.diag(mod_sim)
autocorr.diag(mod_sim)
effectiveSize(mod_sim)
summary(mod_sim)