###############################################################################
# Kruskal-Wallis
#------------------------------------------------------------------------------
# by Umer Zeeshan Ijaz (http://userweb.eng.gla.ac.uk/umer.ijaz)
#
###############################################################################

#==============================================================================
# LIBRARY DEPENDENCE
#==============================================================================
library(reshape)
library(ggplot2)

#==============================================================================
# Let's rock'n'roll!
#==============================================================================
# Load the abundance table
abund_table <- read.csv("SPE_pitlatrine.csv",row.names=1,check.names=FALSE)

# Transpose the data to have sample names on rows
abund_table <- t(abund_table)

# Get grouping information
grouping_info <- data.frame(row.names=rownames(abund_table),t(as.data.frame(strsplit(rownames(abund_table),"_"))))

# Use countries as grouping information
groups <- as.factor(grouping_info[,1])

# Apply normalisation (either use relative or log-relative transformation)
# data <- abund_table/rowSums(abund_table)
data <- log((abund_table+1)/(rowSums(abund_table)+dim(abund_table)[2]))
data <- as.data.frame(data)

# Reference: http://www.bigre.ulb.ac.be/courses/statistics_bioinformatics/practicals/microarrays_berry_2010/berry_feature_selection.html
kruskal.wallis.alpha=0.01
kruskal.wallis.table  <-  data.frame()
for (i in 1:dim(data)[2]) {
  ks.test  <-  kruskal.test(data[,i], g=groups)
  #  Store the result in the data frame
  kruskal.wallis.table  <-  rbind(kruskal.wallis.table,
                                data.frame(id=names(data)[i],
                                           p.value=ks.test$p.value
                                ))
  #  Report number of values tested
  cat(paste("Kruskal-Wallis test for ",names(data)[i]," ", i, "/",
            dim(data)[2], "; p-value=", ks.test$p.value,"\n", sep=""))
}

kruskal.wallis.table$E.value  <-  kruskal.wallis.table$p.value * dim(kruskal.wallis.table)[1]

kruskal.wallis.table$FWER  <-  pbinom(q=0, p=kruskal.wallis.table$p.value,
                                    size=dim(kruskal.wallis.table)[1], lower.tail=FALSE)

kruskal.wallis.table  <-  kruskal.wallis.table[order(kruskal.wallis.table$p.value,
                                                   decreasing=FALSE), ]
kruskal.wallis.table$q.value.factor  <-  dim(kruskal.wallis.table)[1] / 1:dim(kruskal.wallis.table)[1]
kruskal.wallis.table$q.value  <-  kruskal.wallis.table$p.value * kruskal.wallis.table$q.value.factor
pdf("KW_correction.pdf")
plot(kruskal.wallis.table$p.value,
     kruskal.wallis.table$E.value,
     main='Multitesting corrections',
     xlab='Nominal p-value',
     ylab='Multitesting-corrected statistics',
     log='xy',
     col='blue',
     panel.first=grid(col='# BBBBBB',lty='solid'))
lines(kruskal.wallis.table$p.value,
      kruskal.wallis.table$FWER,
      pch=20,col='darkgreen', type='p'
)
lines(kruskal.wallis.table$p.value,
      kruskal.wallis.table$q.value,
      pch='+',col='darkred', type='p'
)
abline(h=kruskal.wallis.alpha, col='red', lwd=2)
legend('topleft', legend=c('E-value', 'p-value', 'q-value'), col=c('blue', 'darkgreen','darkred'), lwd=2,bg='white',bty='o')
dev.off()

last.significant.element  <-  max(which(kruskal.wallis.table$q.value <= kruskal.wallis.alpha))
selected  <-  1:last.significant.element
diff.cat.factor  <-  kruskal.wallis.table$id[selected]
diff.cat  <-  as.vector(diff.cat.factor)

print(kruskal.wallis.table[selected,])

#==============================================================================
# Plots
#==============================================================================

# Now we plot taxa significantly different between the categories
df <- NULL
for(i in diff.cat){
  tmp <- data.frame(data[,i],groups,rep(paste(i," q = ",round(kruskal.wallis.table[kruskal.wallis.table$id==i,"q.value"],5),sep=""),dim(data)[1]))
  if(is.null(df)){df <- tmp} else { df <- rbind(df,tmp)}
}
colnames(df) <- c("Value","Type","Taxa")

p <- ggplot(df,aes(Type,Value,colour=Type))+ylab("Log-relative normalised")
p <- p+geom_boxplot()+geom_jitter()+theme_bw()+
  facet_wrap( ~ Taxa , scales="free", ncol=3)
p <- p+theme(axis.text.x=element_text(angle=90,hjust=1,vjust=0.5))
pdf("KW_significant.pdf",width=10,height=14)
print(p)
dev.off()


# Read Rating
raw_data <- read.csv(
    "chapter06/data/ml-100k/u.data",
    sep = "\t", header = FALSE
)
colnames(raw_data) <- c("UserId", "MovieId", "Rating", "TimeStamp")
ratings <- raw_data[, 1:3]
head(ratings)

movies <- read.csv(
    "chapter06/data/ml-100k/u.item",
    sep = "|", header = FALSE
)

# Read Movie
colnames(movies) <- c(
    "MovieId", "MovieTitle", "ReleaseDate", "VideoReleaseDate",
    "IMDbURL", "Unknown", "Action", "Adventure", "Animation",
    "Children", "Comedy", "Crime", "Documentary", "Drama",
    "Fantasy", "FilmNoir", "Horror", "Musical", "Mystery",
    "Romance", "SciFi", "Thriller", "War", "Western"
)
movies <- movies[, -c(2:5)]
head(movies)

# Merge Rating and Movie
ratings <- merge(
    x = ratings,
    y = movies,
    by = "MovieId",
    all.x = TRUE
)
head(ratings)
names(ratings)

# Scale 5 Rating to Binary
nrat <- unlist(lapply(ratings$Rating, function(x) {
    if (x > 3) {
        return (1)
    }
    else {
        return (0)
    }
}))
ratings <- cbind(ratings, nrat)
head(ratings)

# EDA
apply(ratings[, -c(1:3, 23)], 2, function(x) table(x))

# Remove Unknown and Original Rating
scaled_ratings <- ratings[, -c(3, 4)]

# Scaling Rating
scaled_ratings <- scale(scaled_ratings[, -c(1, 2, 21)])
scaled_ratings <- cbind(scaled_ratings, ratings[, c(1, 2, 23)])
head(scaled_ratings)

# Train/Test Split
set.seed(7)
which_train <- sample(
    x = c(TRUE, FALSE),
    size = nrow(scaled_ratings),
    replace = TRUE,
    prob = c(0.8, 0.2)
)
model_data_train <- scaled_ratings[which_train, ]
model_data_test <- scaled_ratings[!which_train, ]

dim(model_data_train)
dim(model_data_test)

# Modeling: Random Forest
library(randomForest)
fit <- randomForest(
    as.factor(nrat)~.,
    data = model_data_train[, -c(19, 20)]
)
summary(fit)
fit

# Prediction
predictions <- predict(fit, model_data_test[, -c(19, 20, 21)], type = "class")
predictions[0:20]

cm <- table(predictions, model_data_test$nrat)
accuracy <- sum(diag(cm)) / sum(cm)
precision <- diag(cm) / rowSums(cm)
recall <- diag(cm) / colSums(cm)
accuracy
precision
recall

# Recommendation for User
total_movie_ids <- unique(movies$MovieId)
non_rated_movie_df <- function(user_id) {
    rated_movies <- raw_data[raw_data$UserId == user_id, ]$MovieId
    non_rated_movies <- total_movie_ids[!total_movie_ids %in% rated_movies]
    df <- data.frame(cbind(rep(user_id), non_rated_movies, 0))
    names(df) <- c("UserId", "MovieId", "Rating")
    return(df)
}
active_user_non_rated_movie_df <- non_rated_movie_df(943)
active_user_ratings <- merge(
    x = active_user_non_rated_movie_df,
    y = movies,
    by = "MovieId",
    all.x = TRUE
)
head(active_user_ratings)

predictions <- predict(fit, active_user_ratings[, -c(1:4)], type = "class")
recommendation <- data.frame(
    movieId = active_user_ratings$MovieId,
    predictions
)
recommendation <- recommendation[which(recommendation$predictions == 1), ]
head(recommendation)


#' THI
#'
#' Given air temperature (Celsius), relative humidity  gives Temperature Humidity Index discomfort. Giles (1990).
#'
#' @param t numeric  Air temperature in Celsius degrees.
#' @param rh numeric Relative humidity in percentage.
#' @return Temperature Humidity Index discomfort
#'
#' @author Istituto per la Bioeconomia CNR Firenze Italy  Alfonso Crisci \email{alfonso.crisci@@ibe.cnr.it}
#' @keywords  THI, Temperature Humidity Index
#'
#' @export
#'
#'
#'
#'

THI=function(t,rh) {
                         ct$assign("t", as.array(t))
                         ct$assign("rh", as.array(rh))
                         ct$eval("var res=[]; for(var i=0, len=t.length; i < len; i++){ res[i]=THI(t[i],rh[i])};")
                         res=ct$get("res")
                         return(ifelse(res==9999,NA,res))
}


library("swirl")
swirl()
head(flags)
dim(flags)
class(flags)
cls_list <- lapply(flags, class)
cls_list
class(cls_list)
as.character(cls_list)
cls_vect <- sapply(flags, class)
class(cls_vect)
sum(flags$orange)
flag_colors <- flags[,11:17]
head(flag_colors)
View(flag_colors)
lapply(flag_colors, sum)
sapply(flag_colors, sum)
sapply(flag_colors, mean)
flag_shapes <- flags[, 19:23]
View(flag_shapes)
lapply(flag_shapes, range)
shape_mat <- sapply(flag_shapes,range)
shape_mat
class(shape_mat)
unique(c(3,4,5,5,5,6,6,))
unique(c(3,4,5,5,5,6,6))
unique_vals <- lapply(flags, unique)
unique_vals
sapply(unique_vals, length)
supply(flags, unique)
spply(flags, unique)
sapply(flags, unique)
lapply(unique_vals, function(elem) elem[2])
# open minded apply (best for interactive exploration)
sapply(flags, unique)
# typed apply function will throw errors (best for scripting)
vapply(flags, unique, numeric(1))
ok()
sapply(flags, class)
vapply(flags, class, character(1))
?tapply
table(flags$landmass)
table(flags$animate)
tapply(flags$animate, flags$landmass, mean)
tapply(flags$population, flags$red, summary)
# group population summary per landmass
tapply(flags$population, flags$landmass, summary)
ls()
class(plants)
dim(plants)
nrow(plants)
ncol(plants)
object.size(plants)
names(plants)
head(plants)
head(plants, 10)
tail(plants, 15)
# show most frequent values of columns (if categorical, otherwise show std dev etc)
summary(plants)
table(plants$Active_Growth_Period)
# show structure, factors preview of a data set
str(plants)


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

== CONTENTS

* ((<Finite Sets>))
  * ((<Sets>))
  * ((<Maps>))
  * ((<Groups>))
* ((<Calculation of polynomials>))
* ((<Calculation of multi-variate polynomials>))
* ((<Calculation of multi-variate polynomials (2)>))
* ((<Remainder of the division of a polynomial by polynomials>))
* ((<Groebner basis>))
* ((<Prime field>))
* ((<Algebraic field>))
  * ((<This can be done as following>))
* ((<Quotient fields>))
  * ((<By taking the quotient field of the ring of Integer, rational numbers are obtained.>))
  * ((<Rational function field>))
  * ((<Rational function field over the algebraic extension field>))
  * ((<Algebraic function field>))
* ((<Linear Algebra>))
  * ((<Linear equations>))
  * ((<Diagonalization of Square Matrix>))
  * ((<Elementary Divisors of Matrix>))
  * ((<Jordan Canonical Form of Matrix>))
  * ((<The proofs of the theorem of Cayley-Hamilton>))
* ((<The expression of Groebner basis by original generators>))
* ((<The quotients and the remainder by arbitrary basis>))
* ((<Factorization>))
  * ((<Factorization of Integer coefficient polynomial>))
  * ((<Factorization of Zp coefficient polynomial>))
  * ((<Factorization over the algebraic extension of Rational>))
  * ((<Factorization over the algebraic extension of the algebraic extension of Rational>))
  * ((<Factorization of x^4 + 10x^2 + 1>))
  * ((<Factorization of Integer or Rational coefficient multi-variate polynomial>))
  * ((<Factorization of Zp coefficient multi-variate polynomial>))
* ((<Algebraic Equations>))
  * ((<Minimal Polynomial>))
  * ((<Minimal Splitting Field>))
  * ((<Galois Group of polynomials>))
* ((<Geometry>))
  * ((<Existance of a barycenter>))
  * ((<Existance of a circumcenter>))
  * ((<Existance of a orthocenter>))
  * ((<4 triangles>))
* ((<Analysis>))
  * ((<Lagrange Multiplier>))

== Finite Sets

=== Sets

<<< sample-set01.rb.v.rd

=== Maps

<<< sample-map01.rb.v.rd

=== Groups

<<< sample-group01.rb.v.rd

== Calculation of polynomials

<<< sample-polynomial01.rb.v.rd

== Calculation of multi-variate polynomials

<<< sample-polynomial02.rb.v.rd

== Calculation of multi-variate polynomials (2)

<<< sample-m-polynomial01.rb.v.rd

== Remainder of the division of a polynomial by polynomials

<<< sample-divmod01.rb.v.rd

== Groebner basis

<<< sample-groebner01.rb.v.rd

== Prime field

<<< sample-primefield01.rb.v.rd

== Algebraic field

<<< sample-algebraicfield01.rb.v.rd

=== This can be done as following

<<< sample-algebraicfield02.rb.v.rd

=== Calculation of roots

<<< sample-algebraic-root01.rb.v.rd

== Quotient fields

=== By taking the quotient field of the ring of Integer, rational numbers are obtained.

<<< sample-quotientfield01.rb.v.rd

=== Rational function field

<<< sample-quotientfield02.rb.v.rd

=== Rational function field over the algebraic extension field

<<< sample-quotientfield03.rb.v.rd

=== Algebraic function field

<<< sample-quotientfield04.rb.v.rd

== Linear Algebra

=== Linear equations

<<< sample-gaussian-elimination01.rb.v.rd

=== Diagonalization of Square Matrix

<<< sample-diagonalization01.rb.v.rd

=== Elementary Divisors of Matrix

<<< sample-elementary-divisor01.rb.v.rd

=== Jordan Canonical Form of Matrix

<<< sample-jordan-form01.rb.v.rd

=== The proofs of the theorem of Cayley-Hamilton

<<< sample-cayleyhamilton01.rb.v.rd

== The expression of Groebner basis by original generators

<<< sample-groebner02.rb.v.rd

== The quotients and the remainder by arbitrary basis

<<< sample-groebner03.rb.v.rd

== Factorization

=== Factorization of Integer coefficient polynomial

<<< sample-factorize01.rb.v.rd

=== Factorization of Zp coefficient polynomial

<<< sample-factorize02.rb.v.rd

=== Factorization over the algebraic extension of Rational

<<< sample-factorize03.rb.v.rd

=== Factorization over the algebraic extension of the algebraic extension of Rational

<<< sample-factorize04.rb.v.rd

=== Factorization of x^4 + 10x^2 + 1

<<< sample-factorize05.rb.v.rd

=== Factorization of Integer or Rational coefficient multi-variate polynomial

<<< sample-m-factorize01.rb.v.rd

=== Factorization of Zp coefficient multi-variate polynomial

<<< sample-m-factorize02.rb.v.rd

== Algebraic Equations

=== Minimal Polynomial

<<< sample-algebraic-equation01.rb.v.rd

=== Minimal Splitting Field

<<< sample-splitting-field01.rb.v.rd

=== Galois Group of polynomials

<<< sample-galois-group01.rb.v.rd

== Geometry
=== Existance of a barycenter

<<< sample-geometry01.rb.v.rd

=== Existance of a circumcenter

<<< sample-geometry02.rb.v.rd

#=== Existance of a incenter

#<<< sample-geometry03.rb.v.rd

=== Existance of a orthocenter

<<< sample-geometry04.rb.v.rd

=== 4 triangles
see ((<URL:http://www1.odn.ne.jp/drinkcat/topic/column/quest/quest_2/quest_2.html>)) Question 3.

<<< sample-geometry07.rb.v.rd

== Analysis
=== Lagrange Multiplier
<<< sample-lagrange-multiplier01.rb.v.rd

=end


cl <- kmeans(iris[,-5], 3)
plot(iris[,-5], col = cl$cluster)
points(cl$centers, col = 1:3, pch = 8)


beta_calibration <- function(p, y, parameters="abm"){
  p <- pmax(1e-16, pmin(p, 1-1e-16))
  if (parameters == "abm"){
    d <- data.frame(y)
    d$lp <- log(p)
    d$l1p <- -log(1-p)

    fit <- glm(y~lp+l1p,family=binomial(link='logit'),data=d)

    a <- as.numeric(fit$coefficients['lp'])
    b <- as.numeric(fit$coefficients['l1p'])
    if (a < 0){
      fit <- glm(y~l1p,family=binomial(link='logit'),data=d)
      a <- 0
      b <- as.numeric(fit$coefficients['l1p'])
    }else if (b < 0){
      fit <- glm(y~lp,family=binomial(link='logit'),data=d)
      a <- as.numeric(fit$coefficients['lp'])
      b <- 0
    }
    inter <- as.numeric(fit$coefficients['(Intercept)'])
    m <- uniroot(function(mh) b*log(1-mh)-a*log(mh)-inter,c(1e-16,1-1e-16))$root

    calibration <- list("map" = c(a,b,m), "model" = fit, "parameters" = parameters)
    return(calibration)

  }else if (parameters == "am"){
    d <- data.frame(y)
    d$lp <- log(p / (1 - p))

    fit <- glm(y~lp,family=binomial(link='logit'), data=d)

    inter = as.numeric(fit$coefficients['(Intercept)'])
    a <- as.numeric(fit$coefficients['lp'])
    b <- a
    m <- 1.0 / (1.0 + exp(inter / a))

    calibration <- list("map" = c(a,b,m), "model" = fit, "parameters" = parameters)
    return(calibration)

  }else if (parameters == "ab"){
    d <- data.frame(y)
    d$lp <- log(2 * p)
    d$l1p <- log(2*(1-p))

    fit = glm(y~lp+l1p-1,family=binomial(link='logit'), data=d)

    a <- as.numeric(fit$coefficients['lp'])
    b <- -as.numeric(fit$coefficients['l1p'])
    m = 0.5

    calibration <- list("map" = c(a,b,m), "model" = fit, "parameters" = parameters)
    return(calibration)
  }else{
    stop("Unknown parameters. Expected abm, am or ab.")
  }
}


########################
### MEDIATION IN R#######
#### USING LAVAAN########
### CODE ALONG WITH ME###
########################

# This is a skeleton script.
# I have put basic instructions throughout

# In this activity, follow along with me
# practice typing code and executing it

# If you get stuck, the complete code is
# found in the "01b_mediation_code_along_ANSWERS.R"

# STEP 1: LOAD LIBRARIES
# To run the line of code you are on:
# press CTRL + Enter (Windows)
# press COMMAND + Enter (Mac)
# Or, highlight + Enter
library(kableExtra)
library(tidyverse)
library(knitr)
library(lavaan)
library(psych)

# STEP 2: LOAD DATA
# I simulated the below datafile
# aka it is FAKE DATA

cat_dat <- read.csv("cat_dat.csv") # The data is already uploaded and can be loaded

# Print first and last five observations

cat_dat %>%
  headTail()

# food = IV
# weight = MEDIATOR
# lazy = DV

# STEP 3: VISUALIZATION
# It's always a good idea to look at your data.

cat_dat %>%
  select(-id) %>% # telling r what columns we DO NOT want to see
  pairs.panels()

# STEP 4: CREATING OUR MEDIATION MODEL

mod1 <- "# a path IV -> Mediator
         weight ~ a * food

         # b path  Mediator -> DV
         lazy ~ b * weight

         # c prime path  IV -> DV
         lazy ~ cp * food

         # indirect and total effects
         ab := a * b
         total := cp + ab"

# Next, set random seed so results can be reproduced
set.seed(1234)

# STEP 5: RUNNING SEM
# Fit model
# You must specify bootstrapping in the sem() function
# Normally I run 10000, but it takes time.
# To be time efficient, we will only run 1000 today
csem1 <- sem(mod1, data = cat_dat, se = "bootstrap", bootstrap = 1000)

# STEP 6: SUMMARIZE MODEL
# standardized = TRUE adds standardized estimate to the model output.
summary(csem1, standardized = TRUE)

# Print all model parameters
parameterestimates(csem1, boot.ci.type = "bca.simple", standardized = TRUE)

# STEP 7: INTERPRET
# Every 1 degree increase in food intake was associated with an a = 3.216 (S.E. = 0.878) increase
# in weight units (lbs).

# Adjusting for food, every 1-unit (lb) increase in weight was
# associated with being b = 0.448 (S.E. = 0.152) more lazy.

# Increases in food consumption were associated with increases in laziness
# indirectly through increases in weight.

# Specifically, for every a = 3.216 unit increase in the association between food intake
# and weight, there was an ab = 1.440 (S.E. = 0.661) increase in how
# lazy the cat was. (INDIRECT EFFECT)
# Importantly, a bias-corrected bootstrapped confidence interval with 1,000
# samples was above zero, 95% CI [0.56, 3.028].

# Last, there was no strong evidence that food intake
# was associated with cat laziness
# independent of its association with
# weight, c' = 2.349 (S.E. = 0.167, p = 0.044).

#########################
#### PSYCH PACKAGE#######
#########################

## Test same model using psych package
# The syntax for mediation in psych doesn't have as steep a learning curve as lavaan
# but lavaan (and SEM in general) has more flexibility in specifying more involved models.
cat_dat %>%
  psych::mediate(y = "lazy", x = "food", m = "weight", n.iter = 1000) %>%
  print(short = TRUE)


data <- read.csv("OriginalDataSet.csv",TRUE,",") #import data
class(data)
data <- data[,1:8]

data <- na.omit(data)

#select rows for train and test data
train_index <- sample(1:nrow(data), 0.8 * nrow(data))
test_index <- setdiff(1:nrow(data), train_index)

# Build X_train, y_train, X_test, y_test (x-features, y-target columns)
traindata=data[train_index,]
X_train <- data[train_index, -8]
y_train <- data[train_index, "Vital_Status"]

testdata=data[test_index,]
X_test <- data[test_index, -8]
y_test <- data[test_index, "Vital_Status"]

#normalization(as nueral network is sensitive to scale)
data$Size_Of_Cancer <- (data$Size_Of_Cancer - min(data$Size_Of_Cancer))/(max(data$Size_Of_Cancer) - min(data$Size_Of_Cancer))
data$Mobility <- (data$Mobility -min(data$Mobility))/(max(data$Mobility) - min(data$Mobility))
data$Age <- (data$Age -min(data$Age))/(max(data$Age) - min(data$Age))
data$Surface <- (data$Surface -min(data$Surface))/(max(data$Surface) - min(data$Surface))
data$Consistency<- (data$Consistency -min(data$Consistency))/(max(data$Consistency) - min(data$Consistency))

#NEURAL NETWORK
library(neuralnet)
set.seed(0)
#Neural Network

nn <- neuralnet(Vital_Status~Size_Of_Cancer+Mobility+Age+Surface+Consistency+trestbps+chol,data=traindata, hidden = 4, linear.output=FALSE, threshold=0.01)
nn$result.matrix
plot(nn)

output <- compute(nn,testdata[,-1])
p2 <- output$net.result
pred2 <- ifelse(p2>0.5, 1, 0)
tab2<- table(pred2, testdata$Vital_Status)
tab2
accuracy<- 1-sum(diag(tab2))/sum(tab2)
accuracy


#if (require('volesti')) {
#    library(volesti)
#} else {
#    warning('Installing volesti')
#    install.packages('volesti')
#    library(volesti)
#}
require('volesti')

path = "c:/Users/Timon/OneDrive - Danmarks Tekniske Universitet/Denmark/DTU/2019_20_II/software/polytope_"
ext = ".csv"
n <- 0:100
V <- numeric(length = length(n))

for (i in seq_along(n)) {
    N <- n[i]*100
    paste(c(path,N), collapse="")
    A <- read.csv(paste(c(path,"A_",N,ext), collapse=""), sep=",", header=FALSE)
    A <- as.matrix(A)
    b <- read.csv(paste(c(path,"b_",N,ext), collapse=""), sep=",", header=FALSE)
    b <- as.matrix(b)
    P <- Hpolytope$new(A,b)

    old <- Sys.time()
    V[i] <- volume(P)
    new <- Sys.time() - old
    print(new)
    print(N)

}

write.csv(V, paste(c(path,"volumes.csv"), collapse=""))


#
# Create example of separable and overlapping distributions for ctmixtures paper
#
library(mixtools)
library(mvtnorm)
library(ggplot2)
library(ggthemes)
library(mmadsenr)

# Strongly overlapping example
p1 <- rmvnorm(500, c(2500, 200), matrix(c(1000^2, 220^2, 220^2, 60^2),2,2))
p1_df <- as.data.frame(p1)
p1_df$class <- "Model 1"

p4 <- rmvnorm(500, c(2750, 180), matrix(c(1000^2, 220^2, 220^2, 60^2),2,2))
p4_df <- as.data.frame(p4)
p4_df$class <- "Model 2"

combined_df <- rbind(p1_df, p4_df)
overlapping3 <- ggplot(combined_df, aes(x = V1, y = V2)) + ggtitle("(C)") + ylim(-100,450)
overlapping3 <- overlapping3 + geom_point(aes(color = class)) + xlab("Predictor 1") + ylab("Predictor 2") + theme_hc() + scale_colour_hc()
overlapping3 <- overlapping3 + theme(axis.title.y = element_blank()) + labs(color = "Model") + guides(color = FALSE)

# Less overlapping example
p3 <- rmvnorm(500, c(2500, 275), matrix(c(1000^2, 220^2, 220^2, 60^2),2,2))
p3_df <- as.data.frame(p3)
p3_df$class <- "Model 1"

p4 <- rmvnorm(500, c(1200, 150), matrix(c(1000^2, 220^2, 220^2, 60^2),2,2))
p4_df <- as.data.frame(p4)
p4_df$class <- "Model 2"

combined_2_df <- rbind(p3_df, p4_df)
overlapping2 <- ggplot(combined_2_df, aes(x = V1, y = V2)) + ggtitle("(B)") + ylim(-100,450)
overlapping2 <- overlapping2 + geom_point(aes(color = class)) + xlab("Predictor 1") + theme_hc() + scale_colour_hc() + labs(color = "Model")
overlapping2 <- overlapping2 + theme(axis.title.y = element_blank()) + guides(color = FALSE)

# Separable example
p5 <- rmvnorm(500, c(6500, 200), matrix(c(1000^2, 220^2, 220^2, 60^2),2,2))
p5_df <- as.data.frame(p5)
p5_df$class <- "Model 1"

p6 <- rmvnorm(500, c(1500, 100), matrix(c(1000^2, 220^2, 220^2, 60^2),2,2))
p6_df <- as.data.frame(p6)
p6_df$class <- "Model 2"

combined_3_df <- rbind(p5_df, p6_df)
nonoverlapping <- ggplot(combined_3_df, aes(x = V1, y = V2)) + ggtitle("(A)") + ylim(-100,450)
nonoverlapping <- nonoverlapping + geom_point(aes(color = class)) + xlab("Predictor 1") + ylab("Predictor 2") + theme_hc() + scale_colour_hc()+ labs(color = "Model")
nonoverlapping <- nonoverlapping + guides(color = FALSE)

arrange_ggplot2(nonoverlapping, overlapping2, overlapping3)
pdf(file = "../paper/figure/generated/distributional-overlap.pdf", width = 8, height = 8 )
arrange_ggplot2(nonoverlapping, overlapping2, overlapping3)
dev.off()


rm(list = ls())
setwd(dirname(parent.frame(2)$ofile))

library(plyr)
library(dplyr)

apply.rowwise = function (X, fn) {
  return(t(apply(X, 1, fn)))
}

simulate.mse = function (epsilon, sigma.2, samples, operation, digits, extrapolation.lengths) {
  max.length = max(extrapolation.lengths)
  X = matrix(sample(digits, samples*max.length, replace=T), samples, max.length)
  X.noise = X + matrix(rnorm(samples*max.length, 0, sqrt(sigma.2)), samples, max.length)

  # Should a epsilon transformation be done here?
  Z = X.noise

  error.for.length = function (seq.length) {
    X.slice = X[,1:seq.length, drop=FALSE]
    Z.slice = Z[,1:seq.length, drop=FALSE]

    if (operation == 'cumsum') {
      target = apply.rowwise(X.slice, cumsum)
      pred = apply.rowwise(Z.slice, cumsum)
    } else if (operation == 'cumprod') {
      target = apply.rowwise(X.slice, cumprod)
      pred = apply.rowwise(Z.slice, cumprod)
    }

    errors = mean((pred - target)**2)
  }

  df = data.frame(
      operation=operation,
      extrapolation.length=extrapolation.lengths
  ) %>%
    rowwise() %>%
    mutate(
      threshold = error.for.length(extrapolation.length)
    )
  return(df)
}

mse = rbind(
 #simulate.mse(NA, 0.25, 100000, 'cumsum', 0:9, c(1, 10, 100, 1000)), #0.25
 simulate.mse(NA, 0.125, 100000, 'cumprod', 1:9, seq(1,9)) # 0.25
)
print(mse)
write.csv(mse, file="../results/sequential_mnist_mse_expectation.csv", row.names=F)


```{r}

#There's a miscode of New York City and New York state that creates an issue
lhs_long_clean_confirmed_wide <-
  lhs_long_clean %>%
  filter(!is.na(wikidata_id)) %>% #the NA_NA_NA obs were screwing with us
  dplyr::select(dataset, gid_geonameid_wikidata_id, date_asdate, confirmed) %>%
  filter(!is.na(gid_geonameid_wikidata_id) & !is.na(date_asdate)) %>%
  filter(!is.na(confirmed) & confirmed>0 ) %>%
  group_by(dataset, gid_geonameid_wikidata_id, date_asdate) %>%
  summarise(confirmed= max(confirmed, na.rm=T)) %>%
  ungroup() %>%
  pivot_wider(names_from = dataset, values_from = confirmed ) %>%
  mutate_if(is.numeric, list(~na_if(abs(.), Inf))) %>% distinct()
dim(lhs_long_clean_confirmed_wide) #154,499 #161,952

temp <- lhs_long_clean_confirmed_wide %>% dplyr::select(-gid_geonameid_wikidata_id,-date_asdate) %>% as.matrix()
condition <- ncol(temp) - (is.na(temp) %>% rowSums() ) >1
cor1 <- temp[condition,] %>% cor(use="pairwise.complete.obs")
library(ggcorrplot) #install.packages("ggcorrplot")
ggcorrplot(cor1, hc.order = F, type = "lower", lab = TRUE, colors=c("red","white","green"), method = "circle")

#install.packages('heatmaply');
library(heatmaply)
heatmaply(cor1)
hist(cor1[lower.tri(cor1)])

cor_list <- list()
for(q in lhs_long_clean_confirmed_wide$date_asdate %>% unique() %>% sort()  ){
  print(q)
  try({
    cor1 <- NULL
    temp <- lhs_long_clean_confirmed_wide %>% filter(date_asdate==q) %>% dplyr::select(-gid_geonameid_wikidata_id,-date_asdate) %>% as.matrix()
    condition <- ncol(temp) - (is.na(temp) %>% rowSums() ) >1
    cor1 <- temp[condition,] %>% cor(use="pairwise.complete.obs")
    cor_list[[ as.character(q)]] <- cor1[lower.tri(cor1)]
  })
}

plot(sapply(cor_list, mean, na.rm=T))

temp2 <-  lhs_long_clean %>%
  filter(!is.na(wikidata_id)) %>% #the NA_NA_NA obs were screwing with us
  dplyr::select(dataset, gid_geonameid_wikidata_id, date_asdate, confirmed) %>%
  filter(!is.na(gid_geonameid_wikidata_id) & !is.na(date_asdate)) %>%
  filter(!is.na(confirmed) & confirmed>0 ) %>%
  group_by(gid_geonameid_wikidata_id, date_asdate) %>%
  summarise(confirmed_var = var(confirmed, na.rm=T), n_count=n()) %>%
  ungroup() %>%
  mutate_if(is.numeric, list(~na_if(abs(.), Inf))) %>% distinct() %>%
  filter(!is.na(confirmed_var) & n_count>1)

temp2 %>%
  ggplot(aes(x=date_asdate, y=confirmed_var)) +
  geom_point()

temp2 %>%
  ggplot(aes(x=date_asdate %>% as.factor(), y=confirmed_var %>% sqrt() )) +
  geom_boxplot() + ylim(0,1000)

temp2 %>%
  ggplot(aes(x=date_asdate , y=confirmed_var %>% sqrt() )) +
  geom_point() +
  geom_smooth() +
  ylim(0,1000)

#There 3 outliers at least, new york because of a join error, the U.S. because cumulative is off by like 40 k when it gets up to a million

test2 <- lhs_long_clean %>% left_join(temp2)

```


#Tutorial de exemplo de análise de dados com raster
#https://geocompr.robinlovelace.net/location.html

library(raster)
library(sp)
library(sf)
library(lattice)
library(latticeExtra)
library(grid)
library(gridExtra)
library(classInt)
library(mapview)
library(tidyverse)
library(htmlwidgets)
library(leaflet)
library(revgeo)

download.file("https://tinyurl.com/ybtpkwxz",
              destfile = "census.zip", mode = "wb")
unzip("census.zip") # unzip the files
census_de = readr::read_csv2(list.files(pattern = "Gitter.csv"))
input <- census_de %>%
            dplyr::select(
              x = 'x_mp_1km',
              y = 'y_mp_1km',
              pop = 'Einwohner',
              women = 'Frauen_A',
              mean_age = 'Alter_D',
              hh_size = 'HHGroesse_D'
            ) %>%
            mutate_all(
              list(~ifelse(. %in% c(-1, -9), NA, .))
            )
input_ras <- rasterFromXYZ(input, crs = st_crs(3035)$proj4string)

#os dados do censo estão em categorias; as matrizes abaixo vão ajudar a traduzir essas categorias em dados úteis
rcl_pop <- matrix(c(1, 1, 127, 2, 2, 375, 3, 3, 1250,
                   4, 4, 3000, 5, 5, 6000, 6, 6, 8000),
                 ncol = 3, byrow = TRUE)
rcl_women <- matrix(c(1, 1, 3, 2, 2, 2, 3, 3, 1, 4, 5, 0),
                   ncol = 3, byrow = TRUE)
rcl_age <- matrix(c(1, 1, 3, 2, 2, 0, 3, 5, 0),
                 ncol = 3, byrow = TRUE)
rcl_hh <- rcl_women
rcl <- list(rcl_pop, rcl_women, rcl_age, rcl_hh)

#efetuando a reclassificação
reclass <- input_ras
for(i in seq_len(nlayers(reclass))){
  reclass[[i]] <- reclassify(x = reclass[[i]], rcl = rcl[[i]], right =NA)
}
names(reclass) <- names(input_ras)

#Definir as áreas metropolitanas
# áreas metropolitanas: pixels de 20km² com mais de 500.000 habitantes

pop_agg <- aggregate(reclass$pop, fact = 20, fun = sum)
pop_agg <- pop_agg[pop_agg > 500000, drop = FALSE]
polys <- pop_agg %>%
          clump() %>%
          rasterToPolygons() %>%
          st_as_sf()
metros <- polys %>%
            group_by(clumps) %>%
            summarize()

metros_wgs <- st_transform(metros, 4326)
coords <- st_centroid(metros_wgs) %>%
            st_coordinates() %>%
            round(4)

#usar latitudes e longitudes no mapa raster para pegar nomes de cidades no OpenStreetMap, via pacote revgeo
metro_names <- revgeo(longitude = coords[,1], latitude = coords[,2], output = 'frame')
metro_names <- pull(metro_names, city) %>%
                  as.character() %>%
                  ifelse(. == 'Wülfrath', 'Duesseldorf', .)

#baixar dados de lojas já existentes de bicicletas restritas às áreas metropolitanas
#para não ter que baixar todso so dados, pegar no pacote spDataLarge
#O código original itera sobre cada uma das regiões metropolitanas separadas, tentando baixar shops no openestreetmap e convertendo os dados OSM para de classe sf (objetos espaciais)
data('shops', package='spDataLarge')
shops <- st_transform(shops, proj4string(reclass))

#poi: points of interest
poi <- rasterize(x = shops, y = reclass, field='osm_id', fun='count')

#construir matriz de reclassificação
int <- classInt::classIntervals(values(poi), n=4, style='fisher')
int <- round(int$brks)
rcl_poi = matrix(c(int[1], rep(int[-c(1, length(int))], each = 2),
                   int[length(int)] + 1), ncol = 2, byrow = TRUE)
rcl_poi = cbind(rcl_poi, 0:3)
poi <- reclassify(poi, rcl = rcl_poi, right=NA)
names(poi) <- 'poi'
reclass <- addLayer(reclass, poi)
reclass <- dropLayer(reclass, 'pop')
result <- sum(reclass)
plot(result)


large_tensor <- function(X, Y, edges) {
  # X, Y three-dim arrays, edges a list of edges in the network
  # output is a vector res
  # in position e, corresponding to edge (z,p) via the edges-list, it is:
  # the sum over j, k of the product X_pjk * Y_zjk

  J <- dim(X)[2]
  K <- dim(X)[3]
  E <- nrow(edges)

  res <- rep(0,E)
  for (j in 1:J) {
    for (k in 1:K) {
      res <- res + X[edges[,3], j, k] * Y[edges[,2], j, k]
    }
  }
  res
}


# Defines several payoff functions.

make_call_payoff <- function(K)
    # Returns a call payoff function with strike K.
    # The call payoff works for a scalar value as well as an array of values.
    # function(x) pmax(x-K, 0)
    function(x) (x>K)*(x-K) # NOTE: This is somehow TWICE as fast as pmax

make_identity_payoff <- function(K)
    # Identity payoff function. This can be used to reduce the complexity of psi
    # in the Exact method for testing purposes.
    #
    # Args:
    #     X_T (numeric or array-like): The ending value of the process for each path
    # Returns:
    #     (int or float or array-like): X_T
    function(x) x

make_basket_call_payoff <- function(K)
    # Returns a basket call payoff function with strike K.
    # The returned function can be applied to many paths at once
    function(x) {
        # If there is only one asset in the basket (d=1), change x from a vector to a matrix.
        # This will ensure that colMeans works appropriately.
        if (is.vector(x)) x <- matrix(x, nrow=1)

        # Calculate the basket call payoff for each path
        diff <- colMeans(x)-K
        return((diff>0)*diff)
    }

make_basket_call_payoff_exact <- function(K)
    # Returns a basket call payoff function with strike K.
    # The returned function only be applied to a single path.
    function(x)
        return(max(mean(x)-K, 0))


> twenty.four()

Make 24 out of the numbers 1, 6, 7, 5 and the operators +, -, *, /, ( .
Enter 'q' to quit, '!' to select new digits, or '?' to repeat this message.
> 6*(5-1)
Must use each number once.
> 1 + 6*5 - 7
Correct!
New digits: 7, 2, 9, 3
> (7+9)/2*3
Correct!
New digits: 1, 4, 1, 7
> 4*(7-1)
Must use each number once.
> (7-1)*4*1
Correct!
New digits: 1, 5, 2, 8
> (5-1)^2+8
'^' not allowed.
> !
New digits: 2, 8, 5, 2
> 52-28
'52, 28' not allowed.
> (8-2)*(5-2/2)
Must use each number once.
> (8+2)*2+5
Evaluated to 25 ( goal 24 )
> q
Goodbye!


# Day 3: Binary Diagnostic

get_day3_input_path <- function() {
    paste(getwd(), "/2021/Day 3/Day3_input.txt", sep = "")
}

part1 <- function() {
    readings <- readLines(get_day3_input_path())

    total_readings <- length(readings)
    diag_len <- nchar(readings[1])

    diagnostics <- matrix(ncol = diag_len)
    diagnostics <- diagnostics[-1, ]

    gamma_rate <- ""
    epsilon_rate <- ""

    for (i in seq_len(total_readings)) {
        diagnostics <- rbind(diagnostics,
                            strsplit(readings[i], "")[[1]])
    }

    for (i in seq_len(diag_len)) {
        if (sum(diagnostics[, i] == "1") > (total_readings / 2)) {
            gamma_rate <- paste(gamma_rate, "1", sep = "")
            epsilon_rate <- paste(epsilon_rate, "0", sep = "")
        } else {
            gamma_rate <- paste(gamma_rate, "0", sep = "")
            epsilon_rate <- paste(epsilon_rate, "1", sep = "")
        }
    }

    print(strtoi(gamma_rate, base = 2) * strtoi(epsilon_rate, base = 2))
}

part2 <- function() {
    readings <- readLines(get_day3_input_path())

    total_readings <- length(readings)
    diag_len <- nchar(readings[1])

    diagnostics <- matrix(ncol = diag_len)
    diagnostics <- diagnostics[-1, ]

    for (i in seq_len(total_readings)) {
        diagnostics <- rbind(diagnostics,
                            strsplit(readings[i], "")[[1]])
    }

    # Oxygen Generator Rating
    o2_gen_rate <- diagnostics
    for (i in seq_len(diag_len)) {
        if (is.matrix(o2_gen_rate)) {
            if (sum(o2_gen_rate[, i] == "1") >= sum(o2_gen_rate[, i] == "0")) {
                o2_gen_rate <- o2_gen_rate[o2_gen_rate[, i] == "1", ]
            } else {
                o2_gen_rate <- o2_gen_rate[o2_gen_rate[, i] == "0", ]
            }
        } else {
            break
        }
    }

    o2_gen_rate_str <- paste(o2_gen_rate[1:diag_len], collapse = "")

    # CO2 Scrubber Rating
    co2_scrub_rate <- diagnostics
    for (i in seq_len(diag_len)) {
        if (is.matrix(co2_scrub_rate)) {
            if (sum(co2_scrub_rate[, i] == "1") <
                sum(co2_scrub_rate[, i] == "0")) {
                co2_scrub_rate <- co2_scrub_rate[co2_scrub_rate[, i] == "1", ]
            } else {
                co2_scrub_rate <- co2_scrub_rate[co2_scrub_rate[, i] == "0", ]
            }
        } else {
            break
        }
    }

    co2_scrub_rate_str <-  paste(co2_scrub_rate[1:diag_len], collapse = "")

    print(strtoi(o2_gen_rate_str, base = 2) *
        strtoi(co2_scrub_rate_str, base = 2))
}

part1()
part2()


# ET.r

et <- read.csv("ET.csv", header=TRUE)

summary(et)

er1 <- lm(ER ~ Tavg, data=et)
summary(er1)

er2 <- lm(ER ~ Precip, data=et)
summary(er2)

er3 <- lm(ER ~ NPP, data=et)
summary(er3)

es1 <- lm(ES ~ Tavg, data=et)
summary(es1)

es2 <- lm(ES ~ Precip, data=et)
summary(es2)

es3 <- lm(ES ~ NPP, data=et)
summary(es3)

ec1 <- lm(EC ~ Tavg, data=et)
summary(ec1)

ec2 <- lm(EC ~ Precip, data=et)
summary(ec2)

ec3 <- lm(EC ~ NPP, data=et)
summary(ec3)

et1 <- lm(ET ~ Tavg, data=et)
summary(et1)

et2 <- lm(ET ~ Precip, data=et)
summary(et2)

et3 <- lm(ET ~ NPP, data=et)
summary(et3)


insertion_sort <- function(a) {
  for (c in 2:(length(a))) {
    d = c
    while (d > 1 && a[d] < a[d - 1]) {
      t = a[d]
      a[d] = a[d - 1]
      a[d - 1] = t
      d = d - 1
    }
  }
  a
}
startTime <- Sys.time()
insertion_sort(c(8, 71, 6, 25, 4, 3, 2, 12, 1))
endTime <- Sys.time()
timeTaken <- endTime - startTime
cat("Time required : ", as.numeric(timeTaken), "\n")


#user.degree <- read.table("~/Documents/darshan-trace/2013-csr-db/user-degree.txt", quote="\"")
job.degree <- read.table("~/Documents/darshan-trace/2013-csr-db/job-degree.txt", quote="\"")
#process.degree <- read.table("~/Documents/darshan-trace/2013-csr-db/process-degree", quote="\"")

pdf(file="/Users/daidong/Documents/gitrepos/triton-private/papers/meta-graph/exps/jdegree.pdf",height=5, width=8,bg="white")
x = job.degree$V1
y = job.degree$V2

s = sum(y)
x2=seq(1, max(x), by=8)
y2=s*x2^(-3)
y3=s*x2^(-1.7)
y4=s*x2^(-0.5)

maxX=max(log10(x))
maxY=max(log10(y), log10(y2), log10(y3), log10(y4))

plot(log10(x2), log10(y2), type="l", col=2, lwd=3, yaxt="n", xaxt="n", bty="n", xlab="",ylab="", cex = .7,
	xlim=c(0, maxX), ylim=c(0, maxY))
par(new=TRUE)
plot(log10(x2), log10(y3), type="l", col=3, lwd=3, yaxt="n", xaxt="n", bty="n", xlab="",ylab="", cex = .7,
	xlim=c(0, maxX), ylim=c(0, maxY))
par(new=TRUE)
plot(log10(x2), log10(y4), type="l", col=4, lwd=3, yaxt="n", xaxt="n", bty="n", xlab="",ylab="", cex = .7,
	xlim=c(0, maxX), ylim=c(0, maxY))
par(new=TRUE)

plot(log10(x), log10(y), xaxt="n", yaxt="n", xlab="Degree", ylab="Number of Vertices", xlim=c(0, maxX), ylim=c(0, maxY))

ticks=seq(0, maxX, by=1);
labels <- sapply(ticks, function(i) as.expression(bquote(10^ .(i))))
axis(1, at=ticks, labels=labels)

ticks=seq(0, maxY, by=1);
labels <- sapply(ticks, function(i) as.expression(bquote(10^ .(i))))
axis(2, at=ticks, labels=labels, las=1)

legend("topright", legend = c(expression(paste(alpha, " = 3")),
	expression(paste(alpha, " = 1.7")),
	expression(paste(alpha, " = 0.5"))),
	lty=c(1,1,1),
	col=2:4,
	cex=1.5)

invisible(dev.off())


set.seed(123)

y1 <- rnorm(n=2000, mean=50, sd=20)
y2 <- rnorm(n=2000, mean=20, sd=15)
y <- y1 - y2

library(ggplot2)
p <- ggplot(data.frame(x=y), aes(x))
p <- p + geom_density()
ggsave(file='…/ch.6/e/fig-ex3.png', plot=p, dpi=300, w=4, h=3)


=begin
[((<README-ja|URL:README-ja.html>))]  [((<English|URL:../doc/index.html>))]
= 代数パッケージ

  Version: 0.72  (2006.09.16)
  Author: 原 信一郎 (sinara@blade.nagaokaut.ac.jp)

  これは１変数あるいは多変数の多項式を計算するためのライブラリです。

== 0. 最初の一歩

最も簡単な利用法は require "algebra" として、計算を始めることです。

  require "algebra"
  x = Polynomial(Integer, "x").var
  puts( (x+1)**7 )
    #=> x^7 + 7x^6 + 21x^5 + 35x^4 + 35x^3 + 21x^2 + 7x + 1
  puts( (x**7 + 7*x**6 + 21*x**5 + 35*x**4 + 35*x**3 + 21*x**2 + 7*x + 1).factorize )
    #=> (x + 1)^7

== 1. 例題

 * ((<Samples|URL:samples-ja.html>))

== 2. 主なクラス・モジュール

 * ((<Algebra|URL:algebra-ja.html>)) (代数モジュール)
   * ((<Algebra::Polynomial|URL:polynomial-ja.html>)) (1変数多項式環クラス)
   * ((<Algebra::EuclidianRing|URL:euclidian-ring-ja.html>)) (ユークリッド環モジュール)
   * ((<Algebra::MPolynomial|URL:m-polynomial-ja.html>)) (多変数多項式環クラス)
   * ((<Algebra::ResidueClassRing|URL:residue-class-ring-ja.html>)) (剰余環クラス)
   * ((<Algebra::AlgebraicExtensionField|URL:algebraic-extension-field-ja.html>)) (代数拡大体クラス)
   * ((<Algebra::LocalizedRing|URL:localized-ring-ja.html>)) (局所化環クラス)
   * ((<Algebra::MatrixAlgebra|URL:matrix-algebra-ja.html>)) (行列代数クラス)
   * ((<Algebra::AlgebraicParser|URL:algebraic-parser-ja.html>)) (代数式を表す文字列の評価クラス)
   * ((<Algebra::Set|URL:finite-set-ja.html>)) (集合のクラス)
   * ((<Algebra::Map|URL:finite-map-ja.html>)) (写像のクラス)
   * ((<Algebra::Group|URL:finite-group-ja.html>)) (群のクラス)
   * ((<Algebra::PermutationGroup|URL:permutation-group-ja.html>)) (置換群のクラス)
== 3. その他

 * ((<Algebra::ElementaryDivisor|URL:elementary-divisor-ja.html>)) (単因子モジュール)
 * ((<Algebra::JordanForm|URL:jordan-form-ja.html>)) (ジョルダン行列クラス)
 * ((<Algebra::MatrixAlgebraTriplet|URL:matrix-algebra-triplet-ja.html>)) (3つ組行列のクラス)
 * ((<代数方程式ハンドルユーティリティー|URL:algebraic-equation-ja.html>))
 * ((<多項式環相互変換ユーティリティー|URL:polynomial-converter-ja.html>))

== 4. パッケージ内容

=== 総合
  algebra.rb             Algebra ライブラリ一般利用ファイル

=== 一変数関係
  polynomial.rb          １変数多項式環のクラス
  euclidian-ring.rb      ユークリッド整域ユティリティー(G.C.D.の計算)
  polynomial-factor.rb   １変数多項式因数分解ライブラリ
    polynomial-factor-int.rb   整数係数版
    polynomial-factor-zp.rb    Zp係数版
    polynomial-factor-alg.rb   代数的数係数版

=== 多変数関係
  m-polynomial.rb         多変数多項式環のクラス
    m-index.rb            m-polynomial.rb の下請け
  m-polynomial-factor.rb   １変数多項式因数分解ライブラリ
    m-polynomial-factor-int.rb   整数係数版
    m-polynomial-factor-zp.rb    Zp係数版
  groebner-basis.rb       グレブナ基底の計算モジュール
  groebner-basis-coeff.rb 除算の計算モジュール

=== 代数全般
  localized-ring.rb       商体作成ライブラリ
  matrix-algebra.rb       行列代数のクラス
    elementary-divisor.rb 単因子操作モジュール
    matrix-algebra.triplete.rb  3つ組行列クラス
    jordan-form.rb        ジョルダン行列クラス
  residue-class-ring.rb   多項式環の剰余環
  algebraic-extention-field.rb 代数拡大体
  splitting-field.rb      多項式の最小分解体
  galois-group.rb         Galois 群
  linear-algebra.rb       線形代数ライブラリ
  algebraic-equation.rb   代数方程式ライブラリ

=== 基礎部分

  finite-set.rb           集合のクラス
    finite-map.rb         写像のクラス
    finite-group.rb       群のクラス
      permutation-group.rb  置換群のクラス

=== 共通部分
  prime-gen.rb            素数生成クラス
  numeric-supplement.rb   Numeric の補完
  polynomial-converter.rb 多項式環相互変換ユーティリティー
  algebra-system.rb       代数系の共通仕様
  algebraic-parser.rb     多元環の式の文字列表現を評価するモジュール

=== その他
  array-supplement.rb     Array の補完
  doc-ja/                 マニュアル日本語版(RD, HTML, TXT)
  doc/                    マニュアル英語版(RD, HTML, TXT)
  sample/                 サンプルコード
  work/                   （開発作業場所）

== 5. ToDo
#<<< todo.rd
* ((<todo.html|URL:todo.html>))

== 6. Changes
#<<< changes.rd
* ((<changes.html|URL:changes.html>))

=end


f <- function(levels) {
  l0_net <- 367.6820687999996
  l0_load <- 2725.8433333333405

  l1_net <- 13.506289920000007
  l1_load <- 9.873333333333331

  l2_net <- 0.4347581039999998
  l2_load <- 0.495

  l3_net <- 0.0
  l3_load <- 0.0

  time <- l0_load / levels[1] + l1_load / levels[2] + l1_net / (50.0 * levels[2]) + l2_load / levels[3] + l2_net / (50.0 * levels[3]) + l3_load / levels[4] + l3_net / (50.0 * levels[4])

  sla0 <- 0.0 * 20.0 * exp(-time/1000.0)
  sla1 <- 0.0 * 200.0 * exp(-time/20.0)
  sla2 <- 0.0 * 100.0 * exp(-time/40.0)
  sla3 <- 587.0 * 50.0 * exp(-time/80.0)

  sla0 + sla1 + sla2 + sla3 - (levels[1] + levels[2] + levels[3] + levels[4]) * 0.2
}


  toScore = function(effect_vec, se_vec){
  #This is just a linear transform, mean and variance transform as well
  #Requires the effect be computed with an estimate and an SE
  if(is.null(effect_vec)){return(NULL)}

	#Scaled effects
	sd_effect = sd(effect_vec)
	est_effect_scaled = effect_vec / sd_effect
	s_effect_scaled = se_vec / sd_effect

	#Statistical z-scores
	est_stat_z = effect_vec / se_vec
	s_stat_z = se_vec / se_vec #1

	#Scaled z-scores
	sd_z = sd(est_stat_z)
	est_stat_z_scaled = effect_vec / (sd_z * se_vec)
	s_stat_z_scaled = se_vec / (sd_z * se_vec)

	return(
		data.frame( est_effect_scaled = est_effect_scaled, s_effect_scaled = s_effect_scaled,
	est_stat_z = est_stat_z, s_stat_z = s_stat_z,
	est_stat_z_scaled = est_stat_z_scaled,
	s_stat_z_scaled = s_stat_z_scaled)
	)
  }


#   __      _____             _              __        _
# <(o )___ |  _  |___ ___ ___| |_ ___ ___   |  |   ___| |_ ___
# ( ._> /  |   __|  _| -_|_ -|  _| -_|_ -|  |  |__| .'| . |_ -|
#  `---'   |__|  |_| |___|___|_| |___|___|  |_____|__,|___|___|
#==============================================================================
# Circular bubble chart
#==============================================================================
# Title          : Circular bubble chart.r
# Description    : Circular bubble chart plotting.
# Author         : Isaias V. Prestes <isaias.prestes@gmail.com>
# Date           : 20180407
# Version        : 0.0.1
# Usage          : Run in R 3.4
# Notes          : based on
# https://stackoverflow.com/questions/37835023/circular-bubble-chart-with-r
#                  More https://plot.ly/r/bubble-charts/
# R version      : 3.4
#==============================================================================

#==============================================================================
# PACKAGE INSTALATION
#==============================================================================
install.packages("packcircles")
install.packages("bubbles")
install.packages("devtools")
devtools::install_github("jcheng5/bubbles")

#==============================================================================
# LIBRARY DEPENDENCE
#==============================================================================
library(packcircles)
library(bubbles)
library(ggplot2)

#------------------------------------------------------------------------------
# Data generation/preparation and pattern
#------------------------------------------------------------------------------
setwd('C:/Users/Isaias Prestes/Documents/Pesquisas/GitHub/R/Graphical_Visualization')
mydata <- read.table(
  "..//Data//Tomatos.dat",
  sep="\t", header=TRUE)

#------------------------------------------------------------------------------
# Visualising circular bubble chart
#------------------------------------------------------------------------------
percfac <- 0.1
xmin <- min(mydata$x) - (min(mydata$x) * percfac)
xmax <- max(mydata$x) + (max(mydata$x) * percfac)
ymin <- min(mydata$y) - (min(mydata$y) * percfac)
ymax <- max(mydata$y) + (max(mydata$y) * percfac)
res <- circleRepelLayout(mydata[,2:4], xlim=c(xmin, xmax), ylim=c(ymin, ymax), maxiter = 1000)
dat <- circlePlotData(res$layout)

doPlot <- function(dat, title) {
	ggplot(dat) +
	geom_polygon(aes(x, y, group=id), colour="tomato", fill="tomato", alpha=0.3) +
	coord_equal(xlim=c(min(mydata$x),max(mydata$x)), ylim=c(min(mydata$y),max(mydata$y))) +
	theme_bw() +
	theme(axis.text=element_blank(),
		axis.ticks=element_blank(),
		axis.title=element_blank()) +
	labs(title=title)
}

doPlot(mydata, "")

# bubbles ---------------------------------------------------------------------

bubbles(value = runif(26), label = LETTERS,
  color = rainbow(26, alpha=NULL)[sample(26)]
)

text = as.character(seq(from = 1, to = 476))
bubbles(value = count,
        color = rainbow(length(count), alpha=NULL)[sample(length(count))],
        label = text,
        width=1600, height=1600)

# EOF


# prueba de c oncepto , small world y free scale
library(here)
testthat::test_that(
    "prueba concepto small world y free scale R",{

        source(here:::here("funcs","imports.r"),encoding = "UTF-8") # asi toma la ultima version
        source(here:::here("funcs","funciones.r"),encoding = "UTF-8") # asi toma la ultima version

        # setup
        cota_seccion <- c("Trabajos Originales")
        db_limpia <- "db_raab_grafos.sqlite"
        cota_anio <-  c(1996:2016)
        # cota_anio <- c("1996")
        art_full <- articulos_todos_grafo(db_limpia,anios = cota_anio,secciones = cota_seccion)
        gb_ok <- armado_grafo_bipartito(art_full)
        g_aut <- extraccion_grafo_coautoria(gb_ok,art_full,width_multiplier = 3)

        # esto fue par ala escritura de tesis para ver los tributos y hacer ejemplos
        # igraph::vertex_attr_names(g_aut)
        # igraph::vertex_attr(g_aut,index = 10)
        # igraph::edge_attr_names(g_aut)
        # igraph::edge_attr(g_aut,index = "a0187--a0208" )
        # igraph::edge_attr(g_aut,name = "id" )
        # igraph::edge_attr(g_aut,)
        # E(g_aut)[1]$weight
        # E(g_aut)[1]$id
        # E(g_aut)[10]$fuerza_colaboracion
        # E(g_aut)$anios %>% as_tibble() %>% filter(str_length(value)>7)
        # E(g_aut)[1]$autores
        # E(g_aut)[1]$autor1_label
        # E(g_aut)[1]$autor2_label
        # E(g_aut)[1]$color
        # E(g_aut)[1]$width
        # V(g_aut)[str_detect(V(g_aut)$label,"Carne")]$size

        # small world

        # extraido de: SAND csardi 2016
        # Work on modeling of this type received a good deal of its impetus from the seminal
        # paper of Watts and Strogatz [146] and the ‘small-world’ network model introduced
        # therein. These authors were intrigued by the fact that many networks in the real
        # world display high levels of clustering, but small distances between most nodes.

        # 1996
        transitivity(g_aut) #  0.6483516 high clustering
        diameter(g_aut) # 3
        average.path.length(g_aut) # 1.472

        # para comparar smallworld
        set.seed(12345)
        g.ws <- sample_smallworld(1, 25, 5, 0.05)
        plot(g.ws, layout=layout.circle, vertex.label=NA)
        # clustering coeficient / transitivity ; va entre 0 y 1: 0.6666667, substantial amount
        transitivity(g.ws)
        # distance between vertices is non-trivial. diameter 10 . avg path = 5.45
        diameter(g.lat100)
        average.path.length(g.ws)

        # 1996 - 2016
        transitivity(g_aut) #  0.5429888 high clustering
        diameter(g_aut) # 11
        average.path.length(g_aut) # 3.410348

        valores_para_red <- calcular_metricas(g_aut)

        simulaciones_to_resumen_ejecucion
        simular_random(iter=100,vertex_count=10, edge_count=40,semilla=12345)

        # FIT POWERLAW ------------------------------------------------------------

        # LEY DE POTENCIA sobre los grados del grafo.

        # ley de potencia ( power fit law)
        resultado_fit_ley_potencia <- power.law.fit(igraph::degree(g_aut))
        # ¿El parámetro alfa de la función es mayor que 1? ¿Si? OK
        resultado_fit_ley_potencia$alpha > 1  # 2.515571
        # ¿El test de ajuste de Kolmogorov-Smirnov es no significativo? OK.
        # Numeric scalar, the p-value of the Kolmogorov-Smirnov test.
        # Small p-values (less than 0.05) indicate that the test rejected the hypothesis
        # that the original data could have been drawn from the fitted power-law distribution.
        resultado_fit_ley_potencia$KS.p < 0.05 #( tiene que dar false ) # 0.5081879 ( no significativo )

        # otro que se vee con el tema de avg path v

        # para comparar smallworld 1996-2016

        # mi objetivo para comparar modelos sería:
        #   comparar contra N modelos random / small world / barabasi albert

# SIMULAR RANDOM ----------------------------------------------------------

        tmp_n <- 10 ; tmp_n*(tmp_n-1)/2
        simular_random(iter=100,vertex_count=10, edge_count=40,semilla=12345)
        simular_random(iter=100,vertex_count=100, edge_count=100,semilla=12345)
        simular_random(iter=100,vertex_count=1000, edge_count=100,semilla=12345)

# SIMULAR SMALLWORD -------------------------------------------------------

        simular_small_world(iter = 100,vertex_count = 50,vecindad = 5,prob_reescritura = 0.05,semilla = 12345)
        simular_small_world(iter = 100,vertex_count = 100,vecindad = 5,prob_reescritura = 0.05,semilla = 12345)
        simular_small_world(iter = 100,vertex_count = 1000,vecindad = 5,prob_reescritura = 0.05,semilla = 12345)

# SIMULAR SCALE FREE ------------------------------------------------------

        simular_scale_free(iter =100 ,vertex_count = 100,poder_pref_attach = 1,m_edges_per_step = 8,semilla = 12345)
        simular_scale_free(iter =100 ,vertex_count = 100,poder_pref_attach = 2,m_edges_per_step = 8,semilla = 12345)
        simular_scale_free(iter =100 ,vertex_count = 100,poder_pref_attach = 3,m_edges_per_step = 8,semilla = 12345)

        simular_scale_free(iter =100 ,vertex_count = 100,poder_pref_attach = 1,m_edges_per_step = 5,semilla = 12345)
        simular_scale_free(iter =100 ,vertex_count = 100,poder_pref_attach = 2,m_edges_per_step = 5,semilla = 12345)
        simular_scale_free(iter =1000 ,vertex_count = 100,poder_pref_attach = 3,m_edges_per_step = 5,semilla = 12345)

        # TENGO
        # - LOS VALORES DE REFERENCIA
        # - la simulacion random
        # - la simulacion SW
        # - la simulacion scale freen

        # como validar smallworld

#        https://stats.stackexchange.com/questions/175492/how-to-test-statistically-whether-my-network-graph-is-a-small-world-network

        valores_para_red <- calcular_metricas(g_aut)
        param_list <- data.frame(param_iter=1000,
                                 param_vertex_count=vcount(g_aut),
                                 param_edge_count=ecount(g_aut),
                                 param_semilla=12345)
        simulacion_random <- simular_random(iter=param_list$param_iter,
                                            vertex_count=param_list$param_vertex_count,
                                            edge_count=param_list$param_edge_count,
                                            semilla=param_list$param_semilla)

        simulaciones_resumen <- simulaciones_to_resumen_ejecucion(simulacion_random,param_list)

        validar_small_world <- function(valores_para_red,
                                        param_list,
                                        simulacion_random,
                                        simulaciones_resumen){

            #λ:=L/Lr. and γ:=C/Cr.
            delta_net <- valores_para_red$avg_path / simulaciones_resumen$mean_avg_path_length
            gamma_net <- valores_para_red$transitivity / simulaciones_resumen$mean_transitivity

            es_small_world <- round(delta_net) == 1  &  gamma_net > 1

            qgraph::smallworldness(g_aut)
        }

        # como validar scale free

    })


matrix(1:12, nrow=3)

array(1:24, dim=c(2,3,4)) #output not shown


#############################################
# Build Model 1: Power Consumption VS Month #
#############################################

############
# For Days #
############

# 2007
year2007 = subset(clean_data,clean_data$Year=='2007')
year2007_Power <- aggregate(year2007$Global_Power,by=list(DayofYear=year2007$DayOfYear),FUN=sum)

png('./img/Data-Build-Model-regression-1-check-2007.png')
par(mfrow=c(3,2))
plot(year2007_Power$DayofYear,year2007_Power$x,xlab="DayofYear",ylab="Power",main='Consumption of Power the whole year 2007')
#dev.off()

# 2008
year2008 = subset(clean_data,clean_data$Year=='2008')
year2008_Power <- aggregate(year2008$Global_Power,by=list(DayofYear=year2008$DayOfYear),FUN=sum)

#png('./img/Data-Build-Model-regression-1-check-2008.png')
plot(year2008_Power$DayofYear,year2008_Power$x,xlab="DayofYear",ylab="Power",main='Consumption of Power the whole year 2008')
#dev.off()

# 2009
year2009 = subset(clean_data,clean_data$Year=='2009')
year2009_Power <- aggregate(year2009$Global_Power,by=list(DayofYear=year2009$DayOfYear),FUN=sum)

#png('./img/Data-Build-Model-regression-1-check-2009.png')
plot(year2009_Power$DayofYear,year2009_Power$x,xlab="DayofYear",ylab="Power",main='Consumption of Power the whole year 2009')
#dev.off()

#############
# For month #
#############

# 2007
year2007 = subset(clean_data,clean_data$Year=='2007')
year2007_Power_Month <- aggregate(year2007$Global_Power,by=list(Month=year2007$Month),FUN=sum)

#png('./img/Data-Build-Model-regression-1-check-2007-month.png')
#par(mfrow=c(3,1))
plot(year2007_Power_Month$Month,year2007_Power_Month$x,xlab="Month",ylab="Power",main='Consumption of Power the whole year 2007')
#dev.off()

# 2008
year2008 = subset(clean_data,clean_data$Year=='2008')
year2008_Power_Month <- aggregate(year2008$Global_Power,by=list(Month=year2008$Month),FUN=sum)

#png('./img/Data-Build-Model-regression-1-check-2008-month.png')
plot(year2008_Power_Month$Month,year2008_Power_Month$x,xlab="Month",ylab="Power",main='Consumption of Power the whole year 2008')
#dev.off()

# 2009
year2009 = subset(clean_data,clean_data$Year=='2009')
year2009_Power_Month <- aggregate(year2009$Global_Power,by=list(Month=year2009$Month),FUN=sum)

#png('./img/Data-Build-Model-regression-1-check-2009-month.png')
plot(year2009_Power_Month$Month,year2009_Power_Month$x,xlab="Month",ylab="Power",main='Consumption of Power the whole year 2009')
dev.off()

############
# Box Plot #
############

png('./img/Data-Build-Model-regression-1-boxplot-2007-day.png')
par(mfrow=c(3,2))
boxplot(year2007_Power$x,main="Year2007Power")
# dev.off()

# png('./img/Data-Build-Model-regression-1-boxplot-2007-Month.png')
boxplot(year2007_Power_Month$x,main="Year2007PowerMonth")
# dev.off()

# png('./img/Data-Build-Model-regression-1-boxplot-2008-day.png')
boxplot(year2008_Power$x,main="Year2008Power")
# dev.off()

# png('./img/Data-Build-Model-regression-1-boxplot-2008-Month.png')
boxplot(year2008_Power_Month$x,main="Year2008PowerMonth")
# dev.off()

# png('./img/Data-Build-Model-regression-1-boxplot-2009-day.png')
boxplot(year2009_Power$x,main="Year2009Power")
# dev.off()

# png('./img/Data-Build-Model-regression-1-boxplot-2009-Month.png')
boxplot(year2009_Power_Month$x,main="Year2009PowerMonth")
dev.off()

###############
# Model Build #
###############

year2007_Power_Month$Month <- as.numeric(as.character(year2007_Power_Month$Month))
m <- nls(x~a*Month^2+b*Month+c,data=year2007_Power_Month,start=list(a=300,b=11,c=7))

png('./img/Data-Build-Model-regression-1-Model-and-Validate.png')
par(mfrow=c(3,1))
plot(year2007_Power_Month$Month,year2007_Power_Month$x,xlab="Month(2007)",ylab="Power")
lines(year2007_Power_Month$Month,predict(m),col="red",lty=2,lwd=3)

legend('top',legend=capture.output(summary(m)),cex=0.6)
#dev.off()

#png('./img/Data-Build-Model-regression-1-Model-Validate-2008.png')
plot(year2008_Power_Month$Month,year2008_Power_Month$x,xlab="Month(2008)",ylab="Power")
lines(year2008_Power_Month$Month,predict(m),col="red",lty=2,lwd=3)
#dev.off()

#png('./img/Data-Build-Model-regression-1-Model-Validate-2009.png')
plot(year2009_Power_Month$Month,year2009_Power_Month$x,xlab="Month(2009)",ylab="Power")
lines(year2009_Power_Month$Month,predict(m),col="red",lty=2,lwd=3)
dev.off()


ind <- sample(2,nrow(iris), replace = TRUE, prob=c(0.7,0.3))
trainData <- iris[ind==1,]
testData <- iris[ind==2,]
library(randomForest)

rf <- randomForest(Species ~ . , data = trainData, ntree=100, proximity=TRUE)

print(rf)
plot(rf)


#' hi_index
#'
#' Given air temperature (Celsius), relative humidity  gives a heat stress index in Celsius degree for primates animals.
#'
#' @param t   numeric Air temperature in degC.
#' @param rh  numeric Relative humidity in percentage.
#' @return hi_index
#'
#'
#' @author    Istituto per la Bioeconomia CNR Firenze Italy  Alfonso Crisci \email{alfonso.crisci@@ibe.cnr.it}
#' @keywords  hi_index
#' @references Hill et al,2004, Indices of environmental temperatures for primates in open habitats.
#' @export
#'
#'
#'
#'

hi_index=function(t,rh) {
                         ct$assign("t", as.array(t))
                         ct$assign("rh", as.array(rh))
                         ct$eval("var res=[]; for(var i=0, len=t.length; i < len; i++){ res[i]=hi_index(t[i],rh[i])};")
                         res=ct$get("res")
                         return(ifelse(res==9999,NA,res))
}


function(x, y, pho = 0.1, a = 1, pflag = F){
  #x = data matrix
  #y = labels
  #pho = proportion of items to hold out
  #a = alpha (mixing proportion) for elastic net. 1 is lasso, 0 is ridge

  nipcl <- length(y)/2 #number of items per class
  x <- x[order(y),]    #Sort data to make classes contiguous
  y <- y[order(y)]     #Sort labels to make classes contiguous

  #below creates a "shuffled" vector used to select hold-outs with equal numbers
  #of items held out from each class
  s <- c(c(1:nipcl)[order(runif(nipcl))], c(1:nipcl)[order(runif(nipcl))])
  nfolds <- floor(1/pho) #Compute number of folds as 1/proportion of holdouts
  nhos <- pho * nipcl    #Number of held-out items per class
  o <- rep(NA, times = nfolds)  #Vector to hold output

  for(i1 in c(1:nfolds)){
    tsmin <- (i1-1)*nhos + 1 #Minimum index for test-set in each fold
    tsmax <- i1*nhos         #Maximum index for test-set in each fold

    xtrn <- x[(s < tsmin) | (s > tsmax),] #Training set
    ytrn <- y[(s < tsmin) | (s > tsmax)]  #Training labels

    xtst <- x[(s >= tsmin) & (s <= tsmax),]  #Testing set
    ytst <- y[(s >= tsmin) & (s <= tsmax)]   #Testing labels

    #Fit the model
    m <- cv.glmnet(xtrn, ytrn, family="binomial", alpha = a)

    if(pflag) plot(m) #Plot error curve if plot flag is true

    p <- predict(m, xtst) #Generate predictions of best model for test set
    p <- as.numeric(p > 0) #Convert to binary rep for comparison to true labels
    o[i1] <- sum(p==ytst)/length(ytst)  #compute and store proportion correct for test set
  }
 o #return vector of hold-out accuracy for each fold

}


# box plot of daily flows at selected gauges, in five year bins
# Uses USGS dataRetrieval package
# tutorial here: https://owi.usgs.gov/R/dataRetrieval.html#1
# Albuquerque gauge to use as example: 08330000
# uses log scale - easier to visualize given variability, particularly
# at low end

library(dataRetrieval)
library(tidyverse)
library(lubridate)

#get gauge number
siteNo <- readline(prompt="Enter a gauge number: ")

# get station metadata
gauge_meta <- readNWISsite(siteNo)

# reasonable start date
startDate <- "1895-02-01"
endDate <- Sys.Date()

# statistics of interest - this is mean daily discharge
pCode <- "00060"
statCd <- "00003"

# retrieve data
gauge <- as_tibble(gauge <- readNWISdv(siteNo, pCode, startDate, endDate,
                    statCd))
# use pipes to rename flow variable, select ones we need, and
# add the year
gauge_daily <- gauge %>%
  rename(flow = X_00060_00003) %>%
  select(Date, flow) %>%
  mutate(year=year(Date))

#check to remove spurious negative number that showed up that one time
gauge_daily <- filter(gauge_daily, flow>0)

# get today's yday

today <- yday(Sys.time())

gauge_daily$yday <- yday(gauge_daily$Date)
startdate <- paste("Distribution of daily flows, five year bins\nUSGS gauge",
                   gauge_meta$site_no,
                   "\nData series start: ",
                   gauge_daily$Date[1])

gauge_daily$fiveyr <- floor((gauge_daily$year/5))*5

ggplot(data=gauge_daily, aes(x=yday)) +
  geom_boxplot(mapping = aes(x=factor(fiveyr), y=flow)) +
      scale_y_log10() +
      labs(title=gauge_meta$station_nm,
       x = " ",
       y = "flow, cubic feet per second, log scale",
       caption = "Data: USGS\ngraph: University of New Mexico Water Resources Program\ncode: https://github.com/johnrfleck/water-tools",
       subtitle=startdate) +
  theme(strip.text = element_text(face = "bold", size = 8))
  #scale_y_log10()


REBOL [
    Title:  "Whatever"
    Date:   2-Feb-2000
    File:   %whatever.reb
    Author: "Whatever"
    Version: 1.2.3
]

prime?: func [n] [
    case [
        n = 2 [ true  ]
        n <= 1 or (n // 2 = 0) [ false ]
        true [
            for i 3 round square-root n 2 [
                if n // i = 0 [ return false ]
            ]
            true
        ]
    ]
]

maxLimit: 10000

for i 0 maxLimit - 1 1 [
    print prime? i
]


library(keras)

MnistData <- dataset_mnist()

str(MnistData)

Xtrain <- MnistData$train$x
Ytrain <- MnistData$train$y
Xtest <- MnistData$test$x
Ytest <- MnistData$test$y

table(Ytrain)
table(Ytest)

hist(Ytrain)
hist(Ytest)

dim(Xtrain)
dim(Xtest)

Xtrain <- array_reshape(Xtrain, c(nrow(Xtrain), 784))
Xtest <- array_reshape(Xtest, c(nrow(Xtest), 784))

dim(Xtrain)
dim(Xtest)

Xtrain <- Xtrain / 255
Xtest <- Xtest / 255

Ytrain <- to_categorical(Ytrain, 10)
Ytest <- to_categorical(Ytest, 10)

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

summary(KerasMLPModel)

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

BatchSize <- 128
NumEpochs <- 50

ModelHistory <- KerasMLPModel %>% fit(
  Xtrain, Ytrain,
  batch_size = BatchSize,
  epochs = NumEpochs,
  verbose = 1,
  validation_split = 0.3
)

plot(ModelHistory)

ScoreValues <- KerasMLPModel %>% evaluate(
  Xtrain, Ytrain,
  verbose = 0
)

cat('Test loss:', ScoreValues[[1]], '\n')
cat('Test accuracy:', ScoreValues[[2]], '\n')


library(ggplot2)
source("date.r")
source("explore-data.r")

geo$year_sold <- year(geo$date)
geo$year_sold[geo$year_sold < 1890 | geo$year_sold > 2008] <- NA
geo$year[geo$year < 1890 | geo$year > 2008] <- NA

qplot(year_sold - year, data = geo, binwidth = 1, ylab="age")

# Select all houses that were built close to the time that they were
# sol
new <- subset(geo, year_sold - year <= 6)
new$age <- new$year_sold - new$year

qplot(date, price, data = new, log="y") + facet_wrap(~ age) + geom_smooth(se = F)


  error.propagate = function(x=NULL, error.x=NULL, y=NULL, error.y=NULL, type="") {
    if (type=="product") { # expects y to be the transition matrix
      error.x.sq = (error.x/x)^2
      error.x.sq[ !is.finite(error.x.sq) ] = 0
      error.y.sq =  (error.y/y)^2
      error.y.sq[ !is.finite(error.y.sq) ] = 0

      if (is.array(y) | is.matrix(y) ) {
        error.z = sqrt( as.vector(error.y.sq %*% error.x.sq) )
      } else {
        error.z = sqrt( error.x.sq + error.y.sq )
      }

    } else if (type=="sum") {
      error.x.sq = error.x^2
      error.x.sq[ !is.finite(error.x.sq) ] = 0
      error.y.sq = error.y^2
      error.y.sq[ !is.finite(error.y.sq) ] = 0

      if (is.array(y) | is.matrix(y) ) {
        error.z = sqrt( as.vector( error.x.sq %*% t(error.y.sq) ))
      } else {
        error.z = sqrt( error.x.sq + error.y.sq )
      }

    } else if ( type=="power" ) {
      error.z = abs(y) * error.x/x
      error.z[ !is.finite(error.z) ] = 0
    }
    return(error.z)
  }


#############################
# Spatial Netrate
#'
#' @param tmat timeseries matrix
#' @param dmat distance matrix
#' @param DataType distance data type - euclidian, friction, binary
#' @param SpatialKernel
#' @param fixed vector of fixed parameters
#' @param alpha prior mean and variance for serial interval parameter alpha, if fixed the fixed value
#' @param delta prior mean and variance for distance function parameter delta, if fixed the fixed value
#' @param epsilon prior mean and variance for epsilon edge, if fixed the fixed value
#'
#' @return
#' @export
#'
#' @examples

spatialnetrate <-
  function(tp = tmat,
           dp = dmat,
           DataType = euclidian,
           SpatialKernel = "nil",
           fixed = "epsilon",
           alpha = c(0.003, 0.01),
           delta = c(0.01, 0.01),
           epsilon = 1e-3) {

    library(tensorflow)
    library(reticulate)
    tfp <- reticulate::import("tensorflow_probability",convert=FALSE)

    ###############################
    #key small functions to define
    ##############################

    f1<-function(t,d,a,r) {
      likelihood = a*t*exp(-0.5*a*t*t) * (1/d)^r

      # survival (exp(-0.5*a*t*t) * (1/d)^(r-1) )/(r-1)
      # hazard (a*(r-1)*t)/(d)

      return(likelihood)
    }
    f2<-function(t,d,a,r) {
      likelihood = a*t*exp(-0.5*a*t*t) * exp(-d^2*r)

      # survival (exp(-0.5*a*t*t) * (1/d)^(r-1) )/(r-1)
      # hazard (a*(r-1)*t)/(d)

      return(likelihood)
    }
    f3<-function(t,d,a,r) {
      likelihood = a*t*exp(-0.5*a*t*t) * exp(-abs(d)*r)

      # survival -exp(-0.5*a*t*t - r*d)
      # hazard

      return(likelihood)
    }
    match.cols<-function(val,n){
      colfunc <- colorRampPalette(c("blue","cyan","yellow","orange","red"))
      col<-data.frame(val=seq(min(val),max(val),length.out=n),col=colfunc(n))
      out<-rep(NA,length(col))
      for(i in 1:length(val)){
        out[i]<-as.character(col[which.min(abs(col$val-val[i])),'col'])
      }
      return(out)
    }

    ###################################################
    ## Data defining section
    ###################################################

    #set.seed(1234)
    tf$reset_default_graph()
    N = ncol(tmat) # number of infectors
    Q = nrow(tmat) # number of infectees

    tp = tf$placeholder(shape = shape(Q, N), dtype = tf$float32)
    dp = tf$placeholder(shape = shape(Q, N), dtype = tf$float32)

    ## A defining section
    if (fixed == "alpha") {
      A <- alpha
      #this may need more coding, maybe just A=alpha is okay too?
      A <- tf$constant(alpha, shape = shape(Q, N), dtype = tf$float32)
    } else{
      A <-
        tf$nn$relu(tf$Variable(
          tf$constant(alpha[1], shape = shape(Q, N), dtype = tf$float32),
          name = 'alpha'
        )) # length scale for space
      A <-
        tf$minimum(A, tf$constant(0.01, shape = shape(Q, N), dtype = tf$float32))
      A <- A * tf$sign(tp)
      Ad <-
        tfp$distributions$TruncatedNormal(
          loc = alpha[1],
          scale = alpha[2],
          high = 0.01,
          low = 0.0
        ) #0.005,0.001

    }

    ## D defining section
    if (fixed == "delta") {
      D <- delta

    } else{
      D <-
        tf$nn$relu(tf$Variable(
          tf$constant(delta[1], shape = shape(1L), dtype = tf$float32),
          name = 'distance_scale'
        )) # length scale for space
      #Dd<-tfp$distributions$Exponential(0.001)
      Dd <-
        tfp$distributions$TruncatedNormal(
          loc = delta[1],
          scale = delta[2],
          low = 0.0,
          high = 0.5
        ) #0.005,0.001

    }

    #E defining setcion
    if (fixed == "epsilon") {
      E<-tf$nn$relu(tf$Variable(tf$constant(epsilon,shape=shape(Q),dtype=tf$float32),name='epsilon_edge'))
      #E<-epsilon
    } else{
      E <-
        tf$nn$relu(tf$Variable(
          tf$constant(epsilon[1], shape = shape(Q), dtype = tf$float32),
          name = 'epsilon_edge'
        )) # length scale for space
      Ed <-
        tfp$distributions$TruncatedNormal(epsilon[1],
                                          scale = epsilon[2],
                                          high = 0.9,
                                          low = 0.0)
    }
    if(fixed == "nil"){
      print("no fixed parameters - identifiability could be an issue")
    }
    ###################################################
    ## Spatial kernel section
    ###################################################

    if (SpatialKernel == "exponential") {
      H <- A * tp * tf$exp(-dp * D)

    }else if(SpatialKernel == "Power Law"){
      H <- A * tp * ((1/dp)^D)

    } else if (SpatialKernel == "linear") {
      H <- A * tp * D * dp

    } else if (SpatialKernel == "gaussian"){
      H <- A * tp * (1/(2*3.14*(D*D)))*exp(-dp)/(2*D*D)

    } else {
      H <- A * tp
    }

    #######################################################
    ##tensorflow code
    #######################################################
    nll1 <-
      tf$reduce_sum(log(tf$reduce_sum(H, 1L) + E)) #first loop and second loop
    S <- tf$negative(0.5 * A * tp * tp)

    nll2 <-
      tf$reduce_sum(tf$reduce_sum(S, 1L) - E) #first loop and second loop
    log_prior <-
      tf$negative(tf$reduce_sum(Ad$log_prob(A)) + tf$reduce_sum(Dd$log_prob(D)))
    if(fixed != "epsilon"){
      log_prior <-
        tf$negative(tf$reduce_sum(Ad$log_prob(A)) + tf$reduce_sum(Dd$log_prob(D))+tf$reduce_sum(Ed$log_prob(E)))
    }else{
      log_prior <-
        tf$negative(tf$reduce_sum(Ad$log_prob(A)) + tf$reduce_sum(Dd$log_prob(D)))}
    #log_prior<- tf$negative(tf$reduce_sum(Ad$log_prob(A)))

    nll <- tf$negative(nll1 + nll2)
    log_posterior <- tf$add(nll, log_prior)

    F <-
      H * tf$exp(S) # transmission likelihood is hazard times survival

    train_step = tf$train$AdamOptimizer(1e-3)$minimize(log_posterior) # gradient step size !! IMPORTANT FREE PARAMETER !!
    init = tf$global_variables_initializer()
    myconfig = tf$ConfigProto(log_device_placement = FALSE)
    sess = tf$Session(config = myconfig)
    steps = 10000
    sess$run(init) # initialise session
    nll_store <- 1:steps

    #############################################################
    #BFGS optimising
    #############################################################
    #
    # optimizer = tf$contrib$opt$ScipyOptimizerInterface(
    #   log_posterior,
    #   method = 'L-BFGS-B',
    #   options = dict('maxiter' = 2000000L,
    #                  'disp' = TRUE)
    # )
    # sess = tf$Session()
    # init = tf$global_variables_initializer()
    # sess$run(init) # initialise session
    #
    # optimizer$minimize(session = sess,
    #                    feed_dict = dict(tp = tmat,
    #                                     dp = dmat))
    #
    #
    # #sess$run(E)
    # Ds<-sess$run(D)
    # value <- sess$run(list(nll, log_prior, log_posterior),
    #                   feed_dict = dict(tp = tmat,
    #                                    dp = dmat))
    # print(paste(value[[1]], value[[2]], value[[3]]))
    #

    #manual opt
    for (i in 1:steps) {
      value<-sess$run(list(train_step,nll,log_prior,log_posterior),
                      feed_dict=dict(
                        tp=tmat,
                        dp=dmat
                      ))
      nll_store[i]=value[[2]]
      if(i %% 1000 == 0){
        print(paste(value[[2]],value[[3]],value[[4]]))
        #			print(paste(sess$run(E)))

      }
    }
    # plot(nll_store)

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

    As <- sess$run(list(A), feed_dict = dict(tp = tmat,
                                             dp = dmat))[[1]]
    meanA<-mean(As[As != 0])
    par(mfrow = c(1, 4))
    Fs <- sess$run(list(F), feed_dict = dict(tp = tmat,
                                             dp = dmat))[[1]]
    Ds<-sess$run(D)
    eps_edge<-sess$run(E)
    #eps_edge <- rep(E, nrow(Fs))

    Fs <- cbind(Fs, eps_edge)

    Fs = sweep(Fs, 1, rowSums(Fs), FUN = '/')
    Rt <- colSums(Fs, na.rm=TRUE)[1:(ncol(Fs) - 1)]

    #plotting space-time likelihood and kernels
    x=seq(15,165,length.out=100)
    d=seq(1,200,length.out=100)
    z=expand.grid(x,d)
    r= as.numeric(Ds)
    # par(mfrow=c(1,3))
    #
    # if (SpatialKernel == "exponential") {
    #
    #   y=f3(z[,1]-15,z[,2],meanA,r)
    #
    #   plot(z,col=match.cols(y,1000),pch=15)
    #   plot(d,exp(-d*r),type='b')
    #
    # }else if(SpatialKernel == "Power Law"){
    #
    #   y=f1(z[,1]-15,z[,2],meanA,r)
    #   plot(z,col=match.cols(y,1000),pch=15)
    #   plot(d,(1/d)^r,type='b')
    #
    # } else if (SpatialKernel == "linear") {
    #   H <- A * tp * D * dp
    #
    #
    # } else if (SpatialKernel == "gaussian"){
    #   y=f2(z[,1]-15,z[,2],meanA,r)
    #   plot(z,col=match.cols(y,1000),pch=15)
    #   plot(d,exp(-d^2*r),type='b')
    #
    #
    #
    # } else {
    #
    # }
    #
    #
    # plot(dd$t,Rt)
    # abline(h=mean(Rt))
    #

    return(list(Rt,Ds,As,eps_edge))

  }


 F07FBJ Example Program Results

 Solution(s)
             1          2
 1      1.0000     4.0000
 2     -1.0000     3.0000
 3      2.0000     2.0000
 4     -3.0000     1.0000

 Backward errors (machine-dependent)
        6.7e-17     8.2e-17

 Estimated forward error bounds (machine-dependent)
        2.3e-14     2.4e-14

 Estimate of reciprocal condition number
       1.0e-02

 A has not been equilibrated


# Hello, world!
#
# This is an example function named 'hello'
# which prints 'Hello, world!'.
#
# You can learn more about package authoring with RStudio at:
#
#   http://r-pkgs.had.co.nz/
#
# Some useful keyboard shortcuts for package authoring:
#
#   Build and Reload Package:  'Ctrl + Shift + B'
#   Check Package:             'Ctrl + Shift + E'
#   Test Package:              'Ctrl + Shift + T'

library(shiny)
myData <- c()

#ENTORNO UI.(INTERFAZ)

myFluidPage <- fluidPage(

  #title
  titlePanel("DEMO"),

  #sidebarLayaout
  sidebarLayout(
    sidebarPanel(
      checkboxInput(inputId = "density",
                    label = strong("Show density"),
                    value = FALSE),

      checkboxInput(inputId = "theoretical",
                    label = strong("Show theoretical"),
                    value = FALSE),

    br(),

    sliderInput("bins","Number of bins:",
                  min = 1,
                  max = 50,
                  value = 10)
    ),

    #Gráfico
    mainPanel(
      plotOutput("distPlot")
    )
  )
)

#ENTORNO SERVER.
myShinyServer <- function(input,output,sesion) {

  output$distPlot <- renderPlot({

    #Obtener las bins basados en las bin del UI.R
    x <- myData
    bins <- seq(min(x), max(x), length.out = input$bins + 1) #**

    #Obtener el histograma modificado
    hist(x, breaks = bins, col = "grey86", probability =  TRUE, ylab = "Probability", xlab = "Observations", main = "Histogram") #Breaks muestra el número de bins tan el histograma

    if (input$density){
      dens <- density(x)
      lines(dens, col = "blue", lty=1, lwd=2)
    }

    if (input$theoretical){
      teorico <- dnorm(x,mean=0, sd=1 ,log = FALSE)
      lines(teorico, col = "red", lty=1, lwd=2)
    }

    })
}

myfunction <- function(x)
{
  myData <<- x
  runApp(shinyApp(
    ui = myFluidPage,
    server = myShinyServer
  ))
}

myfunction(x=rnorm(100000))
#myfunction(x=sample(1:100, 1000, replace=TRUE))


#' Decompose/Recompose
#'
#' Exclude the variance contributed by the principal components
#' enumerated in the vector \code{exclude} from the data matrix.
#'
#' @param x
#' A matrix or ddmatrix of numeric values.
#' @param exclude
#' A vector of positive integer values which are the principal components
#' whose variance contribution should be removed.
#' @param center
#' Logical; determines if the matrix should be centered first.
#' @param scale
#' Logical; determines if the matrix should be scaled first.
#'
#' @return
#' A matrix or ddmatrix, matching the same type as the input \code{x}.
#'
#' @references
#' Inspired by a question from Ahmed Moustafa: \url{https://twitter.com/AhmedMoustafa/status/646310686725812224}
#'
#' @author
#' Drew Schmidt
#'
#' @examples
#' \dontrun{
#' ## TODO add mpirun message boilerplate
#' library(pbdDMAT)
#' init.grid()
#'
#' x <- ddmatrix("rnorm", nrow=100, ncol=10, bldim=c(2,2))
#' # Remove the contribution of PC 1's variance
#' decomp_recomp(x, 1)
#'
#' finalize()
#' }
#'
#' @export
decomp_recomp <- function(x, exclude, center=TRUE, scale=FALSE)
{
  if (class(x) != "matrix" && class(x) != "ddmatrix")
    comm.stop("Argument 'x' must be of class 'matrix' or 'ddmatrix'")

  if (any(exclude < 1))
    comm.stop("positive")

  assert.type(center, "logical")
  assert.type(scale, "logical")

  if (center || scale)
    x <- scale(x, center=center, scale=scale)

  svd <- La.svd(x)

  u <- svd$u
  d <- svd$d
  vt <- svd$vt

  ud <- sweep(u[, -exclude], MARGIN=2, FUN="*", STATS=d[-exclude])
  ud %*% vt[-exclude, ]
}


# https://github.com/mulargui/Kaggle---Walmart-forecast-challenge

#working directory
setwd("C:/mauricio/Dropbox/vagrant/apps/Kaggle---Walmart-forecast-challenge")

library("dplyr")

#load data
dftrain <- read.csv("train.csv", header=TRUE)
dftest <- read.csv("test.csv", header=TRUE)

#Add Seasonality Column based on factor of Date
dftrain[,"Seasonality"] <- (as.numeric(dftrain$Date) %% 52) + 1
dftest[,"Seasonality"] <- ((as.numeric(dftest$Date) + 143) %% 52) + 1

#Add Year column
dftrain[,"Year"] <- (as.numeric(format(as.Date(dftrain$Date), "%Y")))
dftest[,"Year"] <- (as.numeric(format(as.Date(dftest$Date), "%Y")))

#add Weekly_Sales column to the test dataset
dftest[,"Weekly_Sales"] <- NA

# for every store (45)
for (i in 1:45)
{
	#for every department (99)
	for (j in 1:99)
	{
		# for every week (52)
		for (k in 1:52)
		{
			#do we have test data?
			dftarget <- dftest %>%
				filter(Store == i) %>%
				filter(Dept == j) %>%
				filter(Seasonality == k)
			if(nrow(dftarget) == 0)
			{
				next
			}
			#do we have train data?
			dfsample <- dftrain %>%
				filter(Store == i) %>%
				filter(Dept == j) %>%
				filter(Seasonality == k)
			if(nrow(dfsample) == 0)
			{
				next
			}

			#apply a linear model
			res <- lm( Weekly_Sales ~ Year, data = dfsample)

			#predict based on the model
			dftest$Weekly_Sales[(dftest$Store==i)&(dftest$Dept == j)&(dftest$Seasonality == k)] <- predict (res,dftarget, interval='prediction')
		}
	}
}

#for depts with no data use 0
dftest$Weekly_Sales[is.na(dftest$Weekly_Sales)] <- 0

#preparing the submission file
#Adding a column with store_department_date
dftest[,"Id"] <- paste(dftest$Store, dftest$Dept, format(as.Date(dftest$Date), "%Y-%m-%d" ), sep = "_")

#save results in a csv file
write.csv(file = "Solution2.csv", x = subset(dftest, select = c(Id, Weekly_Sales)), row.names=FALSE)


# load packages needed to run this code
library(generativeart)
library(ggplot2)
library(tidyr)
library(dplyr)
library(gganimate)
library(gifski)
library(stringr)

#!/usr/bin/env Rscript
args = commandArgs(trailingOnly=TRUE)
seed <- strtoi(args[2])
rare <- strtoi(args[3])
seed
# this function makes generative art
make_frame <- function(seed = 4182, state = 1, formula) {
  # set seed
  set.seed(seed)

  # making a data frame with the visualization
  df <- seq(from = -pi, to = pi, by = 0.02) %>%
    expand.grid(x_i = ., y_i = .) %>%
    dplyr::mutate(!!!formula)

  # split up the data frame to extract the final state
  df %>% select(x, y) %>%
    mutate(state = state)
}

# set different formulas that will be used in the animation

x1 = quote(runif(1, -1, 1) * x_i^2 - sin(y_i^2))
x2 = quote(runif(1, -1, 1) * x_i^3 - sin(y_i^2))
x3 = quote(runif(1, -1, 1) * x_i^3 - sin(y_i^3))

y1 = quote(runif(1, -1, 1) * y_i^3 - cos(x_i^2))
y2 = quote(runif(1, -1, 1) * y_i^4 - cos(x_i^4))
y3 = quote(runif(1, -1, 1) * y_i^3 - cos(x_i^3))

my_formula1 <- list(x = x1, y = y1)
my_formula2 <- list(x = x1, y = y2)
my_formula3 <- list(x = x1, y = y3)
my_formula4 <- list(x = x2, y = y1)
my_formula5 <- list(x = x2, y = y2)
my_formula6 <- list(x = x2, y = y3)
my_formula7 <- list(x = x3, y = y1)
my_formula8 <- list(x = x3, y = y2)
my_formula9 <- list(x = x3, y = y3)
formulas = list(my_formula1, my_formula2, my_formula3, my_formula4, my_formula5, my_formula6, my_formula7, my_formula8, my_formula9)

game_expanded <- function(color) {
  if (color <= 0.03928) {
    return(color / 12.92)
  } else {
    return(`^`((color + 0.055) / 1.055,2.4))
  }
}

source("palettes.r")
source("rares.r")
backgrounds = get_palette(seed)
whites = c();
blacks = c();
winner = "black"

for (i in 1:5) {
  value = backgrounds[i]
  rgb = col2rgb(value)
  r = rgb[1] / 255
  g = rgb[2] / 255
  b = rgb[3] / 255

  luminance = (0.2121 * game_expanded(r)) + (0.7154 * game_expanded(g)) + (0.0721 * game_expanded(b))
  if (luminance > 0.5) {
    blacks <- c(blacks, value[[1]]);
  } else {
    whites <- c(whites, value[[1]]);
  }
}

if (length(blacks) > length(whites)) {
  backgrounds = blacks
  winner = "black"
} else {
  backgrounds = whites
  winner = "white"
}

# make generative art for different seeds
selected_formulas = list()

for(i in sample(1:9, 5)) {
  selected_formulas <- c(selected_formulas, formulas[i])
}

frame1 = make_frame(seed, 1, selected_formulas[[1]])
frame2 = make_frame(seed, 2, selected_formulas[[2]])
frame3 = make_frame(seed, 3, selected_formulas[[3]])

if (length(backgrounds) == 3) {
  rbind(frame1, frame2, frame3) -> df_animate
} else {
  frame4 = make_frame(seed, 4, selected_formulas[[4]])
  if (length(backgrounds) == 4) {
    rbind(frame1, frame2, frame3, frame4) -> df_animate
  } else {
    frame5 = make_frame(seed, 5, selected_formulas[[5]])
    rbind(frame1, frame2, frame3, frame4, frame5) -> df_animate
  }
}

backgrounds
# make a data frame for background colors
df_back <- data.frame(
  xmin = -1.3, ymin = -1.3, xmax = 1.3, ymax = 1.3, x = 0, y = 0,
  fill = backgrounds,
  state = 1:length(backgrounds)
)

# make an animation
# we convert x and y from cartesian to polar coordinates
# we wanted to keep visualization in polar coordinates and we wanted the background to change colors using `gganimate`
# `gganimate` only works on geoms, so the background is drawn with geom_rect()
df_animate %>%
  group_by(state) %>%
  mutate(
    r = (y-min(y))/diff(range(y)), # convert x and y to polar coordinates
    theta = 2*pi*(x-min(x))/diff(range(x))
  ) %>%
  ggplot(ggplot2::aes(x = r*sin(theta), y = r*cos(theta))) +
  geom_rect(
    data = df_back,
    aes(xmin = xmin, xmax = xmax, ymin = ymin, ymax = ymax, fill = fill, group = 1, x = 1, y = 1),
    color = NA
  ) +
  scale_fill_identity() +
  geom_point(alpha = 0.2, size = 0, shape = 20, color = winner) +
  # labs(title = "{closest_state}") +
  theme_void() +
  coord_fixed(expand = FALSE) +
  transition_states(state, transition_length = 10, state_length = 0, wrap = TRUE) -> p_genart

# animate
animate(p_genart,
        device = "png",
        width = 600,
        height = 600,
	      renderer = gifski_renderer())

# save as gif
anim_save(str_interp("samples/${seed}.gif"))


# Run with a few ranks, e.g.
#   mpirun -np 4 Rscript stitch_ddmatrix.r
suppressMessages(library(pbdDMAT))
suppressMessages(library(dmx))
init.grid(quiet=TRUE)

m = 4
n = 3
rank = comm.rank()
x = matrix(1:(m*n) * 10^rank, m, n)
if (rank+1 == comm.size())
  x = x[, 1]

dx = stitch_ddmatrix(x)
dx
comm.print(dx@Data, all.rank=TRUE)

dy = reblock(dx, bldim=c(2,2), ICTXT=0)
dy
comm.print(dy@Data, all.rank=TRUE)

finalize()


#Fit dirlichet models to functional groups of fungi from Tedersoo et al. Temperate Latitude Fungi.
#No hierarchy required, as everything is observed at the site level. Each observation is a unique site.
#Missing data are allowed.
#clear environment
rm(list = ls())
library(data.table)
library(doParallel)
source('paths.r')
source('NEFI_functions/ddirch_site.level_JAGS.r')
source('NEFI_functions/ddirch_site.level_JAGS_int.only.r')
source('NEFI_functions/tic_toc.r')
source('NEFI_functions/crib_fun.r')

#detect and register cores.
n.cores <- detectCores()
registerDoParallel(cores=n.cores)

#set output path.----
output.path <- ted_ITS_prior_phylo.group_JAGSfits

#load tedersoo data.----
d <- data.table(readRDS(tedersoo_ITS_clean_map.path))
y <- readRDS(tedersoo_ITS_common_phylo_groups_list.path)
d <- d[,.(SRR.id,pC,cn,pH,NPP,map,mat,forest,conifer,relEM)]
d <- d[complete.cases(d),] #optional. This works with missing data.
#d <- d[1:35,] #for testing

#Drop in intercept, setup predictor matrix.
x <- d
rownames(x) <- x$SRR.id
x$SRR.id <- NULL
intercept <- rep(1, nrow(x))
x <- cbind(intercept, x)
#IMPORTANT: LOG TRANSFORM MAP.
#log transform map, magnitudes in 100s-1000s break JAGS code.
x$map <- log(x$map)

#fit model using function.
#for running production fit on remote.
cat('Begin model fitting loop...\n')
tic()
output.list<-
foreach(i = 1:length(y)) %dopar% {
  y.group <- y[[i]]
  y.group <- y.group$abundances
  y.group <- y.group[rownames(y.group) %in% d$SRR.id,]
  y.group <- y.group + 1
  y.group <- y.group/rowSums(y.group)
  if(!sum(rownames(y.group) == d$SRR.id) == nrow(y.group)){
     cat('Warning. x and y covariates not in the same order!')
  }
  fit <- site.level_dirlichet_jags(y=y.group,x_mu=x,
                                   adapt = 200, burnin = 2000, sample = 1000,
                                   parallel = T, parallel_method = 'parallel') #setting parallel rather than rjparallel.
  return(fit)                                                                  #allows nested loop to work.
}
cat('Model fitting loop complete! ')
toc()

#get intercept only fit.
#output.list[[length(x.list) + 1]] <- site.level_dirlichet_intercept.only_jags(y=y, silent.jags = T)

#name the items in the list
names(output.list) <- names(y)

cat('Saving fit...\n')
saveRDS(output.list, output.path)
cat('Script complete. \n')


# create a reusable function
barpercent <- function (x, names = NULL, col = "lightblue") {
  # this code orginally written by Naomi b. Robbins
  if (is.null(names)) names <- names(x)
  par (las = 1, mar = c(5,10,4,6), xpd = NA, xaxs = "i", yaxs= "i")
  data <- x[order(x)]*100/sum(x)
  labels <- paste(names[order(x)],"   ",formatC(data,digits=1,format="f",width=4))
  xmax <- round(max(data),digits = -1)
  ymax <- (length(x)*1.2)+.1
  plot(NULL, xlim = c(0,xmax), ylim=c(0,ymax), axes = FALSE, xlab = "percent", ylab="")
  barplot(data, horiz = TRUE, names.arg = labels, col = col, border = col, axes = FALSE, add = TRUE)
  axis (1, pos = 0, xlim = c(0,xmax), at = c(0,1:(xmax/10)*10))
  hat <- -xmax/16.66667
  text(hat, .2, "100.0", adj = c(1,1))
  text(hat, .2, "%", adj = c(0,1))
  lines(c(.3,3.2)*hat,c(.25,.25))
}

# now write some code which uses the function

region<- factor(c("Western Region",
                  "Central Region",
                  "Eastern Region"))

regionSales <- c(342, 246, 363)

barpercent(regionSales, region, col="red")


library(tidyverse)

# Part I ------------------------------------------------------------------

positions <- as.numeric(read.delim("C:/input.txt", header = F, sep = ','))

distance_sum <- function(x) {

positions %>%
  as_tibble() %>%
  mutate(total = abs(value - x)) %>%
  summarize(sum(total))

}

min(map_df(min(positions):max(positions), ~distance_sum(.)))

# Part II -----------------------------------------------------------------
diff <- function(x) {
  positions %>%
  as_tibble() %>%
  mutate(to = x,
         diff = abs(value - to)) %>%
    summarize(total = sum(map_dbl(diff, ~sum(seq(1:.)))))
}

map_df(min(positions):max(positions), ~diff(.)) %>%
  filter(total == min(total))


#' QR
#'
#' QR factorization.
#'
#' @param x
#' An fmlmat matrix.
#' @param qr
#' A compact QR factorization, specifically of class \code{qr_fml} - the return
#' of the \code{qr()} function on \code{fmlmat} data.
#' @param complete,Dvec,...
#' Ignored.
#'
#' @aliases qr.Q qr.R
#'
#' @name qr
#' @rdname qr
NULL

setOldClass("qr_fml")

#' @rdname qr
#' @export
qr.fmlmat = function(x, ...)
{
  x_cp = DATA(x)$dupe()
  qraux = skeleton_vec(x_cp)

  linalg_qr(x_cp, qraux)

  ret = list(
    qr = wrapfml(x_cp),
    rank = NA,
    qraux = wrapfml(qraux),
    pivot = NA
  )

  class(ret) = "qr_fml"
  ret
}

setGeneric(name="qr.Q", useAsDefault=base::qr.Q, package="craze")

#' @rdname qr
#' @export
setMethod("qr.Q", signature(qr="qr_fml"),
  function(qr, complete=FALSE, Dvec)
  {
    Q = skeleton_mat(qr$qr)
    work = skeleton_vec(qr$qr)

    linalg_qr_Q(DATA(qr$qr), DATA(qr$qraux), Q, work)

    wrapfml(Q)
  }
)

setGeneric(name="qr.R", useAsDefault=base::qr.R, package="craze")

#' @rdname qr
#' @export
setMethod("qr.R", signature(qr="qr_fml"),
  function(qr, complete=FALSE)
  {
    R = skeleton_mat(qr$qr)

    linalg_qr_R(DATA(qr$qr), R)

    wrapfml(R)
  }
)


idx <- sample(1:dim(iris)[1],40)
irisSample <- iris[idx,]
irisSample$Species <- NULL
hc <- hclust(dist(irisSample),method="ave")
plot(hc,hang=-1,labels=iris$Speciesp[idx])
# Cuting into 3 clusters only
rect.hclust(hc,k=3)
groups <- cutree(hc,k=3)


library(feather)
library(tidyverse)
library(data.table)
library(brms)
library(bayesplot)
library(tidybayes)
library(brmstools)

setwd("/Users/wbeard/repos/covid/data/")
pl <- function(ct, fn) {
  fn <- paste0("/Users/wbeard/repos/crash/reports/figures/", fn)
  pdf(file = fn,
      width = 24, # The width of the plot in inches
      # height = 4
  )
  plot(ct)
  dev.off()
}

pth <- 'mort_0320.fth'
pth_sim <- 'mort_0320_sim.fth'
df = read_feather(pth) %>% as.data.frame()
nrow(df)
# head(df)
# make_stancode(f, df)

# Model
# f = bf(ldeaths ~ daysi + (1 | state)) + gaussian()
# mdeath1 <- brm(f, df, cores = 4, control = list(adapt_delta = .995))

f = bf(ldeaths ~ (1 | state) + daysi + (0 + daysi | state))
mdeath3 <- brm(f, df, prior = c(
  prior(normal(0, 2), class = b)
  # prior(normal(0, 2), class = sigma),
  # prior(normal(0, 2), class = Intercept)
), cores = 4, control = list(adapt_delta = .995, max_treedepth = 12))
mdeath3
state <- coef(mdeath3)$state[,,2]
state <- data.frame(state = row.names(state), state)
write_feather(as.data.frame(state), 'mort_m2_coef.fth')

m <- brm(bf(ldeaths ~ (1 + daysi | state)), prior =  data = df)
get_prior(f, data = df)

get_prior(bf(ldeaths ~ (1 | state) + (0 + daysi | state)), data = df)
get_prior(bf(ldeaths ~ (1 | state) + daysi + (0 + daysi | state)), data = df)
# , max_treedepth = 13

# marginal_effects
post <- marginal_effects(mdeath1, method = 'predict')
p2 <- plot(post, points = TRUE, plot = FALSE)

# pp_check
pp_check(mdeath1, nsamples = 50)

# Predictions
get_preds <- function(mod, prefix, df_new_base) {
  df <- df_new_base %>%
    add_predicted_draws(mod, prediction = "pred") %>%
    ungroup() %>%
    select(row, pred, state, daysi, .row) %>%
    group_by(row) %>%
    summarise(mu=mean(pred), q10=quantile(pred, p=.1), q90=quantile(pred, p=.9))
  new_names <- paste(prefix, colnames(df), sep="_")
  new_names[1] <- "row"
  colnames(df) <- new_names
  df
}

dfsim = read_feather(pth_sim) %>% as.data.frame()
dfsim_out = get_preds(mdeath3, 'pred', dfsim)
# write_feather(dfsim_out, 'mort_0320_sim_out.fth')
write_feather(dfsim_out, 'mort_v2_sim_out.fth')

# dfsim$row <- 1:nrow(dfsim)


 ZGELQF Example Program Results

 Minimum-norm solution(s)
                    1                 2
 1  (-2.8501, 6.4683) (-1.1682,-1.8886)
 2  ( 1.6264,-0.7799) ( 2.8377, 0.7654)
 3  ( 6.9290, 4.6481) (-1.7610,-0.7041)
 4  ( 1.4048, 3.2400) ( 1.0518,-1.6365)


subroutine dirout(dirsum,nadj,madj,x,y,ntot,npd,rw,eps,nerror)

# Output the description of the Dirichlet tile centred at point
# i for i = 1, ..., npd.  Do this in the original order of the
# points, not in the order into which they have been bin-sorted.
# Called by master.

implicit double precision(a-h,o-z)
dimension nadj(-3:ntot,0:madj), x(-3:ntot), y(-3:ntot)
dimension dirsum(npd,3), rw(4)
logical collin, intfnd, bptab, bptcd, rwu

# Note that at this point some Delaunay neighbours may be
# `spurious'; they are the corners of a `large' rectangle in which
# the rectangular window of interest has been suspended.  This
# large window was brought in simply to facilitate output concerning
# the Dirichlet tesselation.  They were added to the triangulation
# in the routine `dirseg' which ***must*** therefore be called before
# this routine (`dirout') is called.  (Likewise `dirseg' must be called
# ***after*** `delseg' and `delout' have been called.)

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

do i = 1,npd {
        area = 0. # Initialize the area of the ith tile to zero.
	nbpt = 0  # Initialize the number of boundary points of
                  # the ith tile to zero.
        npt = 0   # Initialize the number of tile boundaries to zero.

        np = nadj(i,0)

        # Output the point number, its coordinates, and the number of
        # its Delaunay neighbours == the number of boundary segments in
        # its Dirichlet tile.

        # For each Delaunay neighbour, find the circumcentres of the
        # triangles on each side of the segment joining point i to that
        # neighbour.
        do j1 = 1,np {
                j = nadj(i,j1)
                call pred(k,i,j,nadj,madj,ntot,nerror)
		if(nerror > 0) return
                call succ(l,i,j,nadj,madj,ntot,nerror)
		if(nerror > 0) return
                call circen(i,k,j,a,b,x,y,ntot,eps,collin,nerror)
		if(nerror>0) return
                if(collin) {
			nerror = 13
			return
		}
                call circen(i,j,l,c,d,x,y,ntot,eps,collin,nerror)
		if(nerror>0) return
                if(collin) {
			nerror = 13
			return
		}

                # Increment the area of the current Dirichlet
                # tile (intersected with the rectangular window) by applying
                # Stokes' Theorem to the segment of tile boundary joining
                # (a,b) to (c,d).  (Note that the direction is anti-clockwise.)
                call stoke(a,b,c,d,rw,tmp,sn,eps,nerror)
		if(nerror > 0) return
                area = area+sn*tmp

                # If a circumcentre is outside the rectangular window, replace
                # it with the intersection of the rectangle boundary with the
                # line joining the two circumcentres.  Then output
                # the number of the current Delaunay neighbour and
                # the two circumcentres (or the points with which
                # they have been replaced).
                # Note: rwu = "right way up".
                xi = x(i)
                xj = x(j)
                yi = y(i)
                yj = y(j)
                if(yi!=yj) {
                    slope = (xi - xj)/(yj - yi)
                    rwu = .true.
                } else {
                    slope = 0.d0
                    rwu = .false.
                }
                call dldins(a,b,slope,rwu,ai,bi,rw,intfnd,bptab,nedge)
                if(intfnd) {
                        call dldins(c,d,slope,rwu,ci,di,rw,intfnd,bptcd,nedge)
                	if(!intfnd) {
				nerror = 17
				return
			}
			if(bptab & bptcd) {
				xm = 0.5*(ai+ci)
				ym = 0.5*(bi+di)
				if(xmin<xm&xm<xmax&ymin<ym&ym<ymax) {
					nbpt = nbpt+2
					npt  = npt+1
				}
			}
			else {
				npt = npt + 1
				if(bptab | bptcd) nbpt = nbpt+1
			}
		}
	}
        dirsum(i,1) = npt
        dirsum(i,2) = nbpt
        dirsum(i,3) = area
}

return
end