# Comments start with number symbols.

# You can't make multi-line comments,
# but you can stack multiple comments like so.

# in Windows you can use CTRL-ENTER to execute a line.
# on Mac it is COMMAND-ENTER

#############################################################################
# Stuff you can do without understanding anything about programming
#############################################################################

# In this section, we show off some of the cool stuff you can do in
# R without understanding anything about programming. Do not worry
# about understanding everything the code does. Just enjoy!

data()          # browse pre-loaded data sets
data(rivers)    # get this one: "Lengths of Major North American Rivers"
ls()            # notice that "rivers" now appears in the workspace
head(rivers)    # peek at the data set
# 735 320 325 392 524 450

length(rivers)  # how many rivers were measured?
# 141
summary(rivers) # what are some summary statistics?
#   Min. 1st Qu.  Median    Mean 3rd Qu.    Max.
#  135.0   310.0   425.0   591.2   680.0  3710.0

# make a stem-and-leaf plot (a histogram-like data visualization)
stem(rivers)

#  The decimal point is 2 digit(s) to the right of the |
#
#   0 | 4
#   2 | 011223334555566667778888899900001111223333344455555666688888999
#   4 | 111222333445566779001233344567
#   6 | 000112233578012234468
#   8 | 045790018
#  10 | 04507
#  12 | 1471
#  14 | 56
#  16 | 7
#  18 | 9
#  20 |
#  22 | 25
#  24 | 3
#  26 |
#  28 |
#  30 |
#  32 |
#  34 |
#  36 | 1

stem(log(rivers)) # Notice that the data are neither normal nor log-normal!
# Take that, Bell curve fundamentalists.

#  The decimal point is 1 digit(s) to the left of the |
#
#  48 | 1
#  50 |
#  52 | 15578
#  54 | 44571222466689
#  56 | 023334677000124455789
#  58 | 00122366666999933445777
#  60 | 122445567800133459
#  62 | 112666799035
#  64 | 00011334581257889
#  66 | 003683579
#  68 | 0019156
#  70 | 079357
#  72 | 89
#  74 | 84
#  76 | 56
#  78 | 4
#  80 |
#  82 | 2

# make a histogram:
hist(rivers, col="#333333", border="white", breaks=25) # play around with these parameters
hist(log(rivers), col="#333333", border="white", breaks=25) # you'll do more plotting later

# Here's another neat data set that comes pre-loaded. R has tons of these.
data(discoveries)
plot(discoveries, col="#333333", lwd=3, xlab="Year",
     main="Number of important discoveries per year")
plot(discoveries, col="#333333", lwd=3, type = "h", xlab="Year",
     main="Number of important discoveries per year")

# Rather than leaving the default ordering (by year),
# we could also sort to see what's typical:
sort(discoveries)
#  [1]  0  0  0  0  0  0  0  0  0  1  1  1  1  1  1  1  1  1  1  1  1  2  2  2  2
# [26]  2  2  2  2  2  2  2  2  2  2  2  2  2  2  2  2  2  2  2  2  2  2  3  3  3
# [51]  3  3  3  3  3  3  3  3  3  3  3  3  3  3  3  3  3  4  4  4  4  4  4  4  4
# [76]  4  4  4  4  5  5  5  5  5  5  5  6  6  6  6  6  6  7  7  7  7  8  9 10 12

stem(discoveries, scale=2)
#
#  The decimal point is at the |
#
#   0 | 000000000
#   1 | 000000000000
#   2 | 00000000000000000000000000
#   3 | 00000000000000000000
#   4 | 000000000000
#   5 | 0000000
#   6 | 000000
#   7 | 0000
#   8 | 0
#   9 | 0
#  10 | 0
#  11 |
#  12 | 0

max(discoveries)
# 12
summary(discoveries)
#   Min. 1st Qu.  Median    Mean 3rd Qu.    Max.
#    0.0     2.0     3.0     3.1     4.0    12.0

# Roll a die a few times
round(runif(7, min=.5, max=6.5))
# 1 4 6 1 4 6 4
# Your numbers will differ from mine unless we set the same random.seed(31337)

# Draw from a standard Gaussian 9 times
rnorm(9)
# [1]  0.07528471  1.03499859  1.34809556 -0.82356087  0.61638975 -1.88757271
# [7] -0.59975593  0.57629164  1.08455362

##################################################
# Data types and basic arithmetic
##################################################

# Now for the programming-oriented part of the tutorial.
# In this section you will meet the important data types of R:
# integers, numerics, characters, logicals, and factors.
# There are others, but these are the bare minimum you need to
# get started.

# INTEGERS
# Long-storage integers are written with L
5L # 5
class(5L) # "integer"
# (Try ?class for more information on the class() function.)
# In R, every single value, like 5L, is considered a vector of length 1
length(5L) # 1
# You can have an integer vector with length > 1 too:
c(4L, 5L, 8L, 3L) # 4 5 8 3
length(c(4L, 5L, 8L, 3L)) # 4
class(c(4L, 5L, 8L, 3L)) # "integer"

# NUMERICS
# A "numeric" is a double-precision floating-point number
5 # 5
class(5) # "numeric"
# Again, everything in R is a vector;
# you can make a numeric vector with more than one element
c(3,3,3,2,2,1) # 3 3 3 2 2 1
# You can use scientific notation too
5e4 # 50000
6.02e23 # Avogadro's number
1.6e-35 # Planck length
# You can also have infinitely large or small numbers
class(Inf)  # "numeric"
class(-Inf) # "numeric"
# You might use "Inf", for example, in integrate(dnorm, 3, Inf);
# this obviates Z-score tables.

# BASIC ARITHMETIC
# You can do arithmetic with numbers
# Doing arithmetic on a mix of integers and numerics gives you another numeric
10L + 66L # 76      # integer plus integer gives integer
53.2 - 4  # 49.2    # numeric minus numeric gives numeric
2.0 * 2L  # 4       # numeric times integer gives numeric
3L / 4    # 0.75    # integer over numeric gives numeric
3 %% 2    # 1       # the remainder of two numerics is another numeric
# Illegal arithmetic yeilds you a "not-a-number":
0 / 0 # NaN
class(NaN) # "numeric"
# You can do arithmetic on two vectors with length greater than 1,
# so long as the larger vector's length is an integer multiple of the smaller
c(1,2,3) + c(1,2,3) # 2 4 6
# Since a single number is a vector of length one, scalars are applied
# elementwise to vectors
(4 * c(1,2,3) - 2) / 2 # 1 3 5
# Except for scalars, use caution when performing arithmetic on vectors with
# different lengths. Although it can be done,
c(1,2,3,1,2,3) * c(1,2) # 1 4 3 2 2 6
# Matching lengths is better practice and easier to read
c(1,2,3,1,2,3) * c(1,2,1,2,1,2)

# CHARACTERS
# There's no difference between strings and characters in R
"Horatio" # "Horatio"
class("Horatio") # "character"
class('H') # "character"
# Those were both character vectors of length 1
# Here is a longer one:
c('alef', 'bet', 'gimmel', 'dalet', 'he')
# =>
# "alef"   "bet"    "gimmel" "dalet"  "he"
length(c("Call","me","Ishmael")) # 3
# You can do regex operations on character vectors:
substr("Fortuna multis dat nimis, nulli satis.", 9, 15) # "multis "
gsub('u', 'ø', "Fortuna multis dat nimis, nulli satis.") # "Fortøna møltis dat nimis, nølli satis."
# R has several built-in character vectors:
letters
# =>
#  [1] "a" "b" "c" "d" "e" "f" "g" "h" "i" "j" "k" "l" "m" "n" "o" "p" "q" "r" "s"
# [20] "t" "u" "v" "w" "x" "y" "z"
month.abb # "Jan" "Feb" "Mar" "Apr" "May" "Jun" "Jul" "Aug" "Sep" "Oct" "Nov" "Dec"

# LOGICALS
# In R, a "logical" is a boolean
class(TRUE) # "logical"
class(FALSE)    # "logical"
# Their behavior is normal
TRUE == TRUE    # TRUE
TRUE == FALSE   # FALSE
FALSE != FALSE  # FALSE
FALSE != TRUE   # TRUE
# Missing data (NA) is logical, too
class(NA)   # "logical"
# Use | and & for logic operations.
# OR
TRUE | FALSE    # TRUE
# AND
TRUE & FALSE    # FALSE
# Applying | and & to vectors returns elementwise logic operations
c(TRUE,FALSE,FALSE) | c(FALSE,TRUE,FALSE) # TRUE TRUE FALSE
c(TRUE,FALSE,TRUE) & c(FALSE,TRUE,TRUE) # FALSE FALSE TRUE
# You can test if x is TRUE
isTRUE(TRUE)    # TRUE
# Here we get a logical vector with many elements:
c('Z', 'o', 'r', 'r', 'o') == "Zorro" # FALSE FALSE FALSE FALSE FALSE
c('Z', 'o', 'r', 'r', 'o') == "Z" # TRUE FALSE FALSE FALSE FALSE

# FACTORS
# The factor class is for categorical data
# Factors can be ordered (like childrens' grade levels) or unordered (like gender)
factor(c("female", "female", "male", NA, "female"))
#  female female male   <NA>   female
# Levels: female male
# The "levels" are the values the categorical data can take
# Note that missing data does not enter the levels
levels(factor(c("male", "male", "female", NA, "female"))) # "female" "male"
# If a factor vector has length 1, its levels will have length 1, too
length(factor("male")) # 1
length(levels(factor("male"))) # 1
# Factors are commonly seen in data frames, a data structure we will cover later
data(infert) # "Infertility after Spontaneous and Induced Abortion"
levels(infert$education) # "0-5yrs"  "6-11yrs" "12+ yrs"

# NULL
# "NULL" is a weird one; use it to "blank out" a vector
class(NULL) # NULL
parakeet = c("beak", "feathers", "wings", "eyes")
parakeet
# =>
# [1] "beak"     "feathers" "wings"    "eyes"
parakeet <- NULL
parakeet
# =>
# NULL

# TYPE COERCION
# Type-coercion is when you force a value to take on a different type
as.character(c(6, 8)) # "6" "8"
as.logical(c(1,0,1,1)) # TRUE FALSE  TRUE  TRUE
# If you put elements of different types into a vector, weird coercions happen:
c(TRUE, 4) # 1 4
c("dog", TRUE, 4) # "dog"  "TRUE" "4"
as.numeric("Bilbo")
# =>
# [1] NA
# Warning message:
# NAs introduced by coercion

# Also note: those were just the basic data types
# There are many more data types, such as for dates, time series, etc.

##################################################
# Variables, loops, if/else
##################################################

# A variable is like a box you store a value in for later use.
# We call this "assigning" the value to the variable.
# Having variables lets us write loops, functions, and if/else statements

# VARIABLES
# Lots of way to assign stuff:
x = 5 # this is possible
y <- "1" # this is preferred
TRUE -> z # this works but is weird

# LOOPS
# We've got for loops
for (i in 1:4) {
  print(i)
}
# We've got while loops
a <- 10
while (a > 4) {
    cat(a, "...", sep = "")
    a <- a - 1
}
# Keep in mind that for and while loops run slowly in R
# Operations on entire vectors (i.e. a whole row, a whole column)
# or apply()-type functions (we'll discuss later) are preferred

# IF/ELSE
# Again, pretty standard
if (4 > 3) {
    print("4 is greater than 3")
} else {
    print("4 is not greater than 3")
}
# =>
# [1] "4 is greater than 3"

# FUNCTIONS
# Defined like so:
jiggle <- function(x) {
    x = x + rnorm(1, sd=.1) #add in a bit of (controlled) noise
    return(x)
}
# Called like any other R function:
jiggle(5)   # 5±ε. After set.seed(2716057), jiggle(5)==5.005043

###########################################################################
# Data structures: Vectors, matrices, data frames, and arrays
###########################################################################

# ONE-DIMENSIONAL

# Let's start from the very beginning, and with something you already know: vectors.
vec <- c(8, 9, 10, 11)
vec #  8  9 10 11
# We ask for specific elements by subsetting with square brackets
# (Note that R starts counting from 1)
vec[1]      # 8
letters[18] # "r"
LETTERS[13] # "M"
month.name[9]   # "September"
c(6, 8, 7, 5, 3, 0, 9)[3]   # 7
# We can also search for the indices of specific components,
which(vec %% 2 == 0)    # 1 3
# grab just the first or last few entries in the vector,
head(vec, 1)    # 8
tail(vec, 2)    # 10 11
# or figure out if a certain value is in the vector
any(vec == 10) # TRUE
# If an index "goes over" you'll get NA:
vec[6]  # NA
# You can find the length of your vector with length()
length(vec) # 4
# You can perform operations on entire vectors or subsets of vectors
vec * 4 # 16 20 24 28
vec[2:3] * 5    # 25 30
any(vec[2:3] == 8) # FALSE
# and R has many built-in functions to summarize vectors
mean(vec)   # 9.5
var(vec)    # 1.666667
sd(vec)     # 1.290994
max(vec)    # 11
min(vec)    # 8
sum(vec)    # 38
# Some more nice built-ins:
5:15    # 5  6  7  8  9 10 11 12 13 14 15
seq(from=0, to=31337, by=1337)
# =>
#  [1]     0  1337  2674  4011  5348  6685  8022  9359 10696 12033 13370 14707
# [13] 16044 17381 18718 20055 21392 22729 24066 25403 26740 28077 29414 30751

# TWO-DIMENSIONAL (ALL ONE CLASS)

# You can make a matrix out of entries all of the same type like so:
mat <- matrix(nrow = 3, ncol = 2, c(1,2,3,4,5,6))
mat
# =>
#      [,1] [,2]
# [1,]    1    4
# [2,]    2    5
# [3,]    3    6
# Unlike a vector, the class of a matrix is "matrix", no matter what's in it
class(mat) # => "matrix"
# Ask for the first row
mat[1,] # 1 4
# Perform operation on the first column
3 * mat[,1] # 3 6 9
# Ask for a specific cell
mat[3,2]    # 6

# Transpose the whole matrix
t(mat)
# =>
#      [,1] [,2] [,3]
# [1,]    1    2    3
# [2,]    4    5    6

# Matrix multiplication
mat %*% t(mat)
# =>
#      [,1] [,2] [,3]
# [1,]   17   22   27
# [2,]   22   29   36
# [3,]   27   36   45

# cbind() sticks vectors together column-wise to make a matrix
mat2 <- cbind(1:4, c("dog", "cat", "bird", "dog"))
mat2
# =>
#      [,1] [,2]
# [1,] "1"  "dog"
# [2,] "2"  "cat"
# [3,] "3"  "bird"
# [4,] "4"  "dog"
class(mat2) # matrix
# Again, note what happened!
# Because matrices must contain entries all of the same class,
# everything got converted to the character class
c(class(mat2[,1]), class(mat2[,2]))

# rbind() sticks vectors together row-wise to make a matrix
mat3 <- rbind(c(1,2,4,5), c(6,7,0,4))
mat3
# =>
#      [,1] [,2] [,3] [,4]
# [1,]    1    2    4    5
# [2,]    6    7    0    4
# Ah, everything of the same class. No coercions. Much better.

# TWO-DIMENSIONAL (DIFFERENT CLASSES)

# For columns of different types, use a data frame
# This data structure is so useful for statistical programming,
# a version of it was added to Python in the package "pandas".

students <- data.frame(c("Cedric","Fred","George","Cho","Draco","Ginny"),
                       c(3,2,2,1,0,-1),
                       c("H", "G", "G", "R", "S", "G"))
names(students) <- c("name", "year", "house") # name the columns
class(students) # "data.frame"
students
# =>
#     name year house
# 1 Cedric    3     H
# 2   Fred    2     G
# 3 George    2     G
# 4    Cho    1     R
# 5  Draco    0     S
# 6  Ginny   -1     G
class(students$year)    # "numeric"
class(students[,3]) # "factor"
# find the dimensions
nrow(students)  # 6
ncol(students)  # 3
dim(students)   # 6 3
# The data.frame() function converts character vectors to factor vectors
# by default; turn this off by setting stringsAsFactors = FALSE when
# you create the data.frame
?data.frame

# There are many twisty ways to subset data frames, all subtly unalike
students$year   # 3  2  2  1  0 -1
students[,2]    # 3  2  2  1  0 -1
students[,"year"]   # 3  2  2  1  0 -1

# An augmented version of the data.frame structure is the data.table
# If you're working with huge or panel data, or need to merge a few data
# sets, data.table can be a good choice. Here's a whirlwind tour:
install.packages("data.table") # download the package from CRAN
require(data.table) # load it
students <- as.data.table(students)
students # note the slightly different print-out
# =>
#      name year house
# 1: Cedric    3     H
# 2:   Fred    2     G
# 3: George    2     G
# 4:    Cho    1     R
# 5:  Draco    0     S
# 6:  Ginny   -1     G
students[name=="Ginny"] # get rows with name == "Ginny"
# =>
#     name year house
# 1: Ginny   -1     G
students[year==2] # get rows with year == 2
# =>
#      name year house
# 1:   Fred    2     G
# 2: George    2     G
# data.table makes merging two data sets easy
# let's make another data.table to merge with students
founders <- data.table(house=c("G","H","R","S"),
                       founder=c("Godric","Helga","Rowena","Salazar"))
founders
# =>
#    house founder
# 1:     G  Godric
# 2:     H   Helga
# 3:     R  Rowena
# 4:     S Salazar
setkey(students, house)
setkey(founders, house)
students <- founders[students] # merge the two data sets by matching "house"
setnames(students, c("house","houseFounderName","studentName","year"))
students[,order(c("name","year","house","houseFounderName")), with=F]
# =>
#    studentName year house houseFounderName
# 1:        Fred    2     G           Godric
# 2:      George    2     G           Godric
# 3:       Ginny   -1     G           Godric
# 4:      Cedric    3     H            Helga
# 5:         Cho    1     R           Rowena
# 6:       Draco    0     S          Salazar

# data.table makes summary tables easy
students[,sum(year),by=house]
# =>
#    house V1
# 1:     G  3
# 2:     H  3
# 3:     R  1
# 4:     S  0

# To drop a column from a data.frame or data.table,
# assign it the NULL value
students$houseFounderName <- NULL
students
# =>
#    studentName year house
# 1:        Fred    2     G
# 2:      George    2     G
# 3:       Ginny   -1     G
# 4:      Cedric    3     H
# 5:         Cho    1     R
# 6:       Draco    0     S

# Drop a row by subsetting
# Using data.table:
students[studentName != "Draco"]
# =>
#    house studentName year
# 1:     G        Fred    2
# 2:     G      George    2
# 3:     G       Ginny   -1
# 4:     H      Cedric    3
# 5:     R         Cho    1
# Using data.frame:
students <- as.data.frame(students)
students[students$house != "G",]
# =>
#   house houseFounderName studentName year
# 4     H            Helga      Cedric    3
# 5     R           Rowena         Cho    1
# 6     S          Salazar       Draco    0

# MULTI-DIMENSIONAL (ALL ELEMENTS OF ONE TYPE)

# Arrays creates n-dimensional tables
# All elements must be of the same type
# You can make a two-dimensional table (sort of like a matrix)
array(c(c(1,2,4,5),c(8,9,3,6)), dim=c(2,4))
# =>
#      [,1] [,2] [,3] [,4]
# [1,]    1    4    8    3
# [2,]    2    5    9    6
# You can use array to make three-dimensional matrices too
array(c(c(c(2,300,4),c(8,9,0)),c(c(5,60,0),c(66,7,847))), dim=c(3,2,2))
# =>
# , , 1
#
#      [,1] [,2]
# [1,]    2    8
# [2,]  300    9
# [3,]    4    0
#
# , , 2
#
#      [,1] [,2]
# [1,]    5   66
# [2,]   60    7
# [3,]    0  847

# LISTS (MULTI-DIMENSIONAL, POSSIBLY RAGGED, OF DIFFERENT TYPES)

# Finally, R has lists (of vectors)
list1 <- list(time = 1:40)
list1$price = c(rnorm(40,.5*list1$time,4)) # random
list1
# You can get items in the list like so
list1$time # one way
list1[["time"]] # another way
list1[[1]] # yet another way
# =>
#  [1]  1  2  3  4  5  6  7  8  9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33
# [34] 34 35 36 37 38 39 40
# You can subset list items like any other vector
list1$price[4]

# Lists are not the most efficient data structure to work with in R;
# unless you have a very good reason, you should stick to data.frames
# Lists are often returned by functions that perform linear regressions

##################################################
# The apply() family of functions
##################################################

# Remember mat?
mat
# =>
#      [,1] [,2]
# [1,]    1    4
# [2,]    2    5
# [3,]    3    6
# Use apply(X, MARGIN, FUN) to apply function FUN to a matrix X
# over rows (MAR = 1) or columns (MAR = 2)
# That is, R does FUN to each row (or column) of X, much faster than a
# for or while loop would do
apply(mat, MAR = 2, jiggle)
# =>
#      [,1] [,2]
# [1,]    3   15
# [2,]    7   19
# [3,]   11   23
# Other functions: ?lapply, ?sapply

# Don't feel too intimidated; everyone agrees they are rather confusing

# The plyr package aims to replace (and improve upon!) the *apply() family.
install.packages("plyr")
require(plyr)
?plyr

#########################
# Loading data
#########################

# "pets.csv" is a file on the internet
# (but it could just as easily be be a file on your own computer)
pets <- read.csv("http://learnxinyminutes.com/docs/pets.csv")
pets
head(pets, 2) # first two rows
tail(pets, 1) # last row

# To save a data frame or matrix as a .csv file
write.csv(pets, "pets2.csv") # to make a new .csv file
# set working directory with setwd(), look it up with getwd()

# Try ?read.csv and ?write.csv for more information

#########################
# Statistical Analysis
#########################

# Linear regression!
linearModel <- lm(price  ~ time, data = list1)
linearModel # outputs result of regression
# =>
# Call:
# lm(formula = price ~ time, data = list1)
#
# Coefficients:
# (Intercept)         time
#      0.1453       0.4943
summary(linearModel) # more verbose output from the regression
# =>
# Call:
# lm(formula = price ~ time, data = list1)
#
# Residuals:
#     Min      1Q  Median      3Q     Max
# -8.3134 -3.0131 -0.3606  2.8016 10.3992
#
# Coefficients:
#             Estimate Std. Error t value Pr(>|t|)
# (Intercept)  0.14527    1.50084   0.097    0.923
# time         0.49435    0.06379   7.749 2.44e-09 ***
# ---
# Signif. codes:  0 ‘***’ 0.001 ‘**’ 0.01 ‘*’ 0.05 ‘.’ 0.1 ‘ ’ 1
#
# Residual standard error: 4.657 on 38 degrees of freedom
# Multiple R-squared:  0.6124,  Adjusted R-squared:  0.6022
# F-statistic: 60.05 on 1 and 38 DF,  p-value: 2.44e-09
coef(linearModel) # extract estimated parameters
# =>
# (Intercept)        time
#   0.1452662   0.4943490
summary(linearModel)$coefficients # another way to extract results
# =>
#              Estimate Std. Error    t value     Pr(>|t|)
# (Intercept) 0.1452662 1.50084246 0.09678975 9.234021e-01
# time        0.4943490 0.06379348 7.74920901 2.440008e-09
summary(linearModel)$coefficients[,4] # the p-values
# =>
#  (Intercept)         time
# 9.234021e-01 2.440008e-09

# GENERAL LINEAR MODELS
# Logistic regression
set.seed(1)
list1$success = rbinom(length(list1$time), 1, .5) # random binary
glModel <- glm(success  ~ time, data = list1,
    family=binomial(link="logit"))
glModel # outputs result of logistic regression
# =>
# Call:  glm(formula = success ~ time,
#   family = binomial(link = "logit"), data = list1)
#
# Coefficients:
# (Intercept)         time
#     0.17018     -0.01321
#
# Degrees of Freedom: 39 Total (i.e. Null);  38 Residual
# Null Deviance:        55.35
# Residual Deviance: 55.12   AIC: 59.12
summary(glModel) # more verbose output from the regression
# =>
# Call:
# glm(formula = success ~ time,
#   family = binomial(link = "logit"), data = list1)

# Deviance Residuals:
#    Min      1Q  Median      3Q     Max
# -1.245  -1.118  -1.035   1.202   1.327
#
# Coefficients:
#             Estimate Std. Error z value Pr(>|z|)
# (Intercept)  0.17018    0.64621   0.263    0.792
# time        -0.01321    0.02757  -0.479    0.632
#
# (Dispersion parameter for binomial family taken to be 1)
#
#     Null deviance: 55.352  on 39  degrees of freedom
# Residual deviance: 55.121  on 38  degrees of freedom
# AIC: 59.121
#
# Number of Fisher Scoring iterations: 3

#########################
# Plots
#########################

# BUILT-IN PLOTTING FUNCTIONS
# Scatterplots!
plot(list1$time, list1$price, main = "fake data")
# Plot regression line on existing plot
abline(linearModel, col = "red")
# Get a variety of nice diagnostics
plot(linearModel)
# Histograms!
hist(rpois(n = 10000, lambda = 5), col = "thistle")
# Barplots!
barplot(c(1,4,5,1,2), names.arg = c("red","blue","purple","green","yellow"))

# GGPLOT2
# But these are not even the prettiest of R's plots
# Try the ggplot2 package for more and better graphics
install.packages("ggplot2")
require(ggplot2)
?ggplot2
pp <- ggplot(students, aes(x=house))
pp + geom_histogram()
ll <- as.data.table(list1)
pp <- ggplot(ll, aes(x=time,price))
pp + geom_point()
# ggplot2 has excellent documentation (available http://docs.ggplot2.org/current/)


########################################################
# spectrum_analysis.r                                  #
# Matheus J. Castro                                    #
# Version 2.3                                          #
# Last Modification: 11/11/2021 (month/day/year)       #
# https://github.com/MatheusJCastro/spectra_comparator #
# Licensed under MIT License                           #
########################################################

library("minpack.lm")

# Files Names
files = c("Spectrum_R=14026.csv", "Spectrum_R=6000.csv")

# Load Spectrum 1
spec_wave_1 = read.table(files[1], sep=",", skip=0, nrow=2, header=FALSE, row.names=1, check.names=FALSE)

spec_data_1 = read.table(files[1], sep="", skip=2, header=TRUE, check.names=FALSE)
spec_data_1 = spec_data_1[,1]

# Load Spectrum 2
spec_wave_2 = read.table(files[2], sep=",", skip=0, nrow=2, header=FALSE, row.names=1, check.names=FALSE)

spec_data_2 = read.table(files[2], sep="", skip=2, header=TRUE, check.names=FALSE)
spec_data_2 = spec_data_2[,1]

# Calculate wavelengths
spec_wave_1 = spec_wave_1["CRVAL_1",1] + spec_wave_1["CD1_1",1] * seq.int(0, length(spec_data_1)-1)
spec_wave_2 = spec_wave_2["CRVAL_1",1] + spec_wave_2["CD1_1",1] * seq.int(0, length(spec_data_2)-1)

# Plot Spectra
png(file="Espectra.png", width=1200, height=675)
par(mfrow=c(1, 2))

plot(spec_wave_1, spec_data_1, main="Spectra Comparison",
     xlab="Wavelength", ylab="Intensity", type="l", lty=1,
     cex.axis=2, cex.lab=1.5, cex.main=2)
lines(spec_wave_2, spec_data_2, col="blue")
labels = c(unlist(strsplit(sub(".*_", "", files[1]), "[.]"))[1])
labels = c(labels, unlist(strsplit(sub(".*_", "", files[2]), "[.]"))[1])
legend("topright", legend=c(labels),
       col=c("black", "blue"), lty=1, cex=2)
grid()

interval = 1550:1700
plot(spec_wave_1[interval], spec_data_1[interval], main="Spectra Comparison - zoom in",
     xlab="Wavelength", ylab="Intensity", type="l", lty=1,
     cex.axis=2, cex.lab=1.5, cex.main=2)
lines(spec_wave_2[interval], spec_data_2[interval], col="blue")
labels = c(unlist(strsplit(sub(".*_", "", files[1]), "[.]"))[1])
labels = c(labels, unlist(strsplit(sub(".*_", "", files[2]), "[.]"))[1])
legend("topright", legend=c(labels),
       col=c("black", "blue"), lty=1, cex=2)
grid()

# Find Peaks
find_peaks <- function(spec_data, threshold=NULL, half_window=10){
       peaks = c()

       if(is.null(threshold))
              threshold = mean(spec_data)

       lenspec = length(spec_data)
       for(i in 1:lenspec){
              imin = i - half_window
              imax = i + half_window
              if(imin < 1)
                     imin = 1
              if(imax > lenspec)
                     imax = lenspec

              if(spec_data[i] == max(spec_data[imin:imax]) & spec_data[i] > threshold)
                     peaks = c(peaks, i)
       }

       return(peaks)
}

peaks1 = find_peaks(spec_data_1)
# segments(x0=spec_wave_1[peaks1], y0=spec_data_1[peaks1]*1.1,
       #   y1=spec_data_1[peaks1]*1.1+10000, col="red")

peaks2 = find_peaks(spec_data_2)
# segments(x0=spec_wave_2[peaks2], y0=spec_data_2[peaks2]*1.1,
       #   y1=spec_data_2[peaks2]*1.1+10000, col="green")

# Find Min Max of each Peak
find_min_max_gauss <- function(spec_data, peak){
       miny_old = spec_data[peak]
       j = peak
       while(TRUE){
              miny = spec_data[j]
              if(miny <= miny_old){
                     miny_old = miny
                     j = j - 1
              } else{
                     ind_miny = j
                     break
              }
       }

       maxy_old = spec_data[peak]
       j = peak
       while(TRUE){
              maxy = spec_data[j]
              if(maxy <= maxy_old){
                     maxy_old = maxy
                     j = j + 1
              } else{
                     ind_maxy = j
                     break
              }
       }

       return(c(ind_miny, ind_maxy))
}

# Gaussian function
gauss <- function(x, a, m, s){
       G = a * exp(-1/2 * ((x-m)/s)**2)
}

# Gaussian Fit and Spectrum Analysis
gaussian_fit <- function(spec_wave, spec_data, peaks, plot=FALSE){
       stds = c()
       new_peaks = c()

       for(i in peaks){
              ind_min_max = find_min_max_gauss(spec_data, i)

              x = spec_wave[ind_min_max[1]:ind_min_max[2]]
              y = spec_data[ind_min_max[1]:ind_min_max[2]]

              if(plot){
                     png(file=paste("Fits/Fit_", format(spec_wave[i], digits=2, nsmall=2), ".png", sep=""), width=1200, height=675)
                     plot(x, y, main="Gauss Fit", xlab="Wavelength", ylab="Intensity", type="l", lty=1, lwd=5,
                          cex.axis=2, cex.lab=1.5, cex.main=2)
              }

              chi_square <- function(par){
                     y_gauss = gauss(x, par[1], par[2], par[3])
                     chi = y - y_gauss
                     if(plot) lines(x, gauss(x, par[1], par[2], par[3]), col="lightblue", lty=2)
                     return(chi)
              }

              fit = nls.lm(par=c(1, spec_wave[i], 0.1),# upper=c(280000, spec_wave[i]+100, 5),
                                 fn=chi_square, control=nls.lm.control(maxiter=500))

              if(plot){
                     x = seq(min(x), max(x), 0.01)
                     lines(x, gauss(x, fit$par[1], fit$par[2], fit$par[3]), col="red", lty=2, lwd=2)
                     graphics.off()
              }

              if(fit$par[3] <= 1 & fit$par[3] > 0){
                     stds = c(stds, fit$par[3])
                     new_peaks = c(new_peaks, i)
              }
       }
       return(list(std=stds, peak=new_peaks))
}

# Standard Devations
fit_res = gaussian_fit(spec_wave_1, spec_data_1, peaks1)
stds1 = fit_res$std
std1p = format(mean(stds1), digits=2, nsmall=2)
peaks1 = fit_res$peak

fit_res = gaussian_fit(spec_wave_2, spec_data_2, peaks2)
stds2 = fit_res$std
std2p = format(mean(stds2), digits=2, nsmall=2)
peaks2 = fit_res$peak

# Plot Stds
png(file="Desvio_padrao.png", width=1200, height=675)
par(mfrow=c(1, 2))

hist(stds1, main=paste("Standard Deviation of Original Spectrum Peaks\nwith mean", std1p),
     ylab="Frequency", xlab="Values", breaks=15, col="lightblue",
     cex.axis=2, cex.lab=1.5, cex.main=2)
abline(v=mean(stds1), lty=2, col="red")

hist(stds2, main=paste("Standard Deviation of Reduced Spectrum Peaks\nwith mean", std2p),
     ylab="Frequency", xlab="Values", breaks=15, col="lightblue",
     cex.axis=2, cex.lab=1.5, cex.main=2)
abline(v=mean(stds2), lty=2, col="red")

# Plot Correlation of Stds and Wavelength
png(file="Desvio_Padrao_por_Comp_Onda.png", width=1200, height=675)
par(mfrow=c(1, 2))

plot(spec_wave_1[peaks1], stds1, main="Original Spectrum\nMean of Peaks x Standard Deviation",
     xlab="Wavelength", ylab=expression(sigma), lty=1, col="blue",
     cex.axis=2, cex.lab=1.5, cex.main=2)

plot(spec_wave_2[peaks2], stds2, main="Reduced Spectrum\nMean of Peaks x Standard Deviation",
     xlab="Wavelength", ylab=expression(sigma), lty=1, col="red",
     cex.axis=2, cex.lab=1.5, cex.main=2)

# Change of means for each peak
cross_match <- function(spec1, spec2, radius=10){
       matchs = matrix(, nrow=0, ncol=2)
       colnames(matchs) <- c("Spec1", "Spec2")

       if(length(spec1) >= length(spec2)){
              spec_big = spec1
              spec_few = spec2
       } else{
              spec_big = spec2
              spec_few = spec1
       }

       for(i in 1:length(spec_big)){
              val1 = spec_big[i]
              for(j in 1:length(spec_few)){
                     val2 = spec_few[j]
                     if(val2-radius <= val1 & val2+radius >= val1){
                            if(i %in% matchs[,1]){
                                   ind_rep = which(matchs[,1]==i)
                                   if(abs(val1-val2) < abs(val1-spec_few[matchs[ind_rep,2]]))
                                          matchs[ind_rep,2] = j
                            } else{
                                   matchs = rbind(matchs, c(i, j))
                            }
                     }
              }
       }

       if(length(spec1) < length(spec2)){
              order = c("Spec2", "Spec1")
              matchs = matchs[,order]
       }

       return(matchs)
}

match = cross_match(spec_wave_1[peaks1], spec_wave_2[peaks2])
matchc1 = spec_wave_1[peaks1[match[,1]]]
matchc2 = spec_wave_2[peaks2[match[,2]]]

# Plot Change of Means
png(file="Mudanca_das_Medias.png", width=1200, height=675)
par(mfrow=c(1, 2))

plot(matchc1, abs(matchc1-matchc2),
     main="Wavelengths of Original Spectrum\nPeaks x Drifting from Reduced Spectrum",
     xlab="Original Spectrum Wavelength", ylab="Drifting from Reduced Spectrum Peaks",
     cex.axis=2, cex.lab=1.5, cex.main=2)
abline(h=quantile(abs(matchc1-matchc2), prob=c(.75)), lty=2, col="red")

hist(abs(matchc1-matchc2), breaks=10,
     main="Histogram of Peak Value Differences",
     xlab="Change of Means", ylab="Frequency", col="lightblue",
     cex.axis=2, cex.lab=1.5, cex.main=2)
abline(v=mean(abs(matchc1-matchc2)), lty=2, col="red")

# Quartile of Peaks Change
save_txt = "Qartile of Peaks Change"
save_txt = paste(save_txt, "\n50% =", quantile(abs(matchc1-matchc2), prob=c(.50)))
save_txt = paste(save_txt, "\n75% =", quantile(abs(matchc1-matchc2), prob=c(.75)))

# Identificacion of Blended Lines
blend_indentify <- function(spec1, spec2, radius=0.1){
       blends = matrix(, nrow=0, ncol=2)
       colnames(blends) <- c("Spec1", "Spec2")

       if(length(spec1) >= length(spec2)){
              spec_big = spec1
              spec_few = spec2
       } else{
              spec_big = spec2
              spec_few = spec1
       }

       for(i in 1:length(spec_big)){
              val1 = spec_big[i]
              actual_blend = c()
              for(j in 1:length(spec_few)){
                     val2 = spec_few[j]
                     if(val2-radius <= val1 & val2+radius >= val1){
                            actual_blend = c(actual_blend, j)
                     }

              }
              if(length(actual_blend) > 1){
                     for(j in 1:length(actual_blend))
                            blends = rbind(blends, c(i, actual_blend[j]))
              }
       }

       if(length(spec1) < length(spec2)){
              order = c("Spec2", "Spec1")
              blends = blends[,order]
       }

       return(blends)
}

blend = blend_indentify(spec_wave_1[peaks1], spec_wave_2[peaks2], radius=3*mean(abs(matchc1-matchc2)))
blends1_wave = spec_wave_1[peaks1[blend[,1]]]
blends2_wave = spec_wave_2[peaks2[blend[,2]]]
blends1_data = spec_data_1[peaks1[blend[,1]]]

# Find Correlation of Blend and Intensity
corr_blends <- function(bl1_w, bl1_d){
       intensities = c(50, 40, 25, 12.5, 6.25, 3.125, 0) * 1000

       intens_blends = list()

       for(i in 1:length(intensities)){
              blends_count = c()
              for(j in 1:length(bl1_w)){
                     if(bl1_d[j] >= intensities[i]){
                            if(i == 1)
                                   blends_count = c(blends_count, bl1_w[j])
                            else if(bl1_d[j] <= intensities[i-1])
                                   blends_count = c(blends_count, bl1_w[j])
                     }
              }
              intens_blends[[paste(intensities[i])]] = unique(blends_count)
       }

       return(intens_blends)
}

blends_correlation = corr_blends(blends1_wave, blends1_data)

# Plot Blended Lines in Spectra
png(file="Linhas_com_Blends.png", width=1200, height=675)
plot(spec_wave_1, spec_data_1, main="Blended Lines found for each Intensity level",
     xlab="Wavelength", ylab="Intensity", type="l", lty=1,
     cex.axis=2, cex.lab=1.5, cex.main=2)

for(i in names(blends_correlation)){
       y_inten = rep(as.numeric(i), length(blends_correlation[[i]]))
       points(blends_correlation[[i]], y_inten, col=1+which(i==names(blends_correlation)), pch=4, lwd=3)
}

labels = names(blends_correlation)
legend("topright", legend=labels, title="Intensities levels",
       col=2:(length(names(blends_correlation))+1), lty=1, cex=2)

# Fit Correlation of Blend and Intensity
e_func <- function(x, a, b, c){
       E = b * exp(a*x) + c
}

chi_square_e_func <- function(x, y, par){
       e_teor = e_func(x, par[1], par[2], par[3])
       chi = sum(((y - e_teor)^2)/e_teor)
       return(chi)
}

intens = as.numeric(names(blends_correlation))
fit = optim(par=c(-0.0001, 50, 1), fn=chi_square_e_func, x=as.numeric(names(blends_correlation)), y=lengths(blends_correlation))
save_txt = paste(save_txt, "\nExponential of b*e^(ax)+c")
save_txt = paste(save_txt, "\na =", fit$par[1])
save_txt = paste(save_txt, "\nb =", fit$par[2])
save_txt = paste(save_txt, "\nc =", fit$par[3])

x_inten = seq(min(intens), max(intens), length=1000)
y_count = e_func(x_inten, fit$par[1], fit$par[2], fit$par[3])

# Plot Blended Lines as Intensity function
png(file="Relacao_Blend_Intensidade.png", width=1200, height=675)

plot(intens, lengths(blends_correlation), main="Blended Lines as funtction of Intensity",
     xlab="Intensity", ylab="Blend Line Count", pch=8, cex=2, lwd=2,
     cex.axis=2, cex.lab=1.5, cex.main=2)

lines(x_inten, y_count, lty=2, col="red")

# Save Results
fl <- file("Resultados.txt")
writeLines(save_txt, fl)
close(fl)


library(shiny)
library(ambient)

ui <- function(request) {
    fluidPage(
    sidebarLayout(
        sidebarPanel(
            sliderInput("frequency", "Frequency", min = 0, max = 1, value = 0.01),
            selectInput("fractal", "Fractal", choices = c("none", "fbm", "billow", "rigid-multi")),
            sliderInput("gain", "Gain", min = 0, max = 1, value = 0.5),
        ),
        mainPanel(
            plotOutput("result")
        )
    )
  )
}

server <- function(input, output, session) {

    grid <- long_grid(seq(1, 10, length.out = 1000), seq(1, 10, length.out = 1000))

    noise <- reactive({
        ambient::gen_simplex(
            x = grid$x,
            y = grid$y,
            seed = 42,
            frequency = input$frequency,
            fractal = input$fractal,
            gain = input$gain
        )
    })

    output$result <- renderPlot({
        plot(grid, noise())
    })

    observe({
        reactiveValuesToList(input)
        session$doBookmark()
    })
    onBookmarked(updateQueryString)
}

shinyApp(ui = ui, server = server, enableBookmarking = "url")


library(SuperLearner)
source('utils.r')
source('slfunctions.r')

fitnuisance <- function(data, nfolds,
                        sl_lib = c('SL.myglmnet', 'SL.myglm', 'SL.mean')) {

    candidatesg <- candidatese <- candidatesm <- candidatesb <-
        candidatesd <- sl_lib
    ## extract data
    Y <- data[, "Y"]
    Z <- data[, substr(names(data), 1, 1) == "Z"]
    L <- data[, "L"]
    A <- data[, "A"]
    W <- data[, substr(names(data), 1, 1) == "W"]

    ## observations and cross-validation
    n <- length(A)
    valSets <- split(sample(seq_len(n)), rep(seq_len(nfolds), length = n))

    ## fit nuisance functions
    fitg <- mySL(
        Y = A,
        X = W,
        family = stats::binomial(),
        SL.library = candidatesg,
        validRows = valSets
    )
    fite <- mySL(
        Y = A,
        X = data.frame(Z, W),
        family = stats::binomial(),
        SL.library = candidatese,
        validRows = valSets
    )
    fitm <- mySL(
        Y = Y,
        X = data.frame(Z, L, A, W),
        family = binomial(),
        SL.library = candidatesm,
        validRows = valSets
    )
    fitb <- mySL(
        Y = L,
        X = data.frame(A, W),
        family = stats::binomial(),
        SL.library = candidatesb,
        validRows = valSets
    )
    fitd <- mySL(
        Y = L,
        X = data.frame(Z, A, W),
        family = stats::binomial(),
        SL.library = candidatesd,
        validRows = valSets
    )

    return(list(fitg = fitg, fite = fite, fitm = fitm, fitb = fitb,
                fitd = fitd, valSets = valSets))
}

estimators <- function(data, delta, nuisance, seed, type,
                       sl_lib = c('SL.myglmnet', 'SL.myglm', 'SL.mean')) {

    candidatesv  <- candidatess <- candidatesq <- candidatesubar <- sl_lib

    ## extract data
    Y <- data[, "Y"]
    Z <- data[, substr(names(data), 1, 1) == "Z"]
    L <- data[, "L"]
    A <- data[, "A"]
    W <- data[, substr(names(data), 1, 1) == "W"]

    n <- length(A)

    g1  <- truncate(nuisance$fitg$SL.predict[, 1])
    e1  <- truncate(nuisance$fite$SL.predict[, 1])
    b1A <- nuisance$fitb$SL.predict[, 1]
    d1A <- truncate(nuisance$fitd$SL.predict[, 1])

    g <- A * g1 + (1 - A) * (1 - g1)
    e <- A * e1 + (1 - A) * (1 - e1)
    b <- L * b1A + (1 - L) * (1 - b1A)
    d <- L * d1A + (1 - L) * (1 - d1A)

    b11  <- predict(nuisance$fitb, newdata = data.frame(A = 1, W))$pred[, 1]
    b10  <- predict(nuisance$fitb, newdata = data.frame(A = 0, W))$pred[, 1]
    d11  <- truncate(predict(nuisance$fitd, newdata = data.frame(Z, A = 1, W))$pred[, 1])
    d10  <- truncate(predict(nuisance$fitd, newdata = data.frame(Z, A = 0, W))$pred[, 1])
    m11  <- predict(nuisance$fitm, newdata = data.frame(Z, L = 1, A = 1, W))$pred[, 1]
    m10  <- predict(nuisance$fitm, newdata = data.frame(Z, L = 1, A = 0, W))$pred[, 1]
    m01  <- predict(nuisance$fitm, newdata = data.frame(Z, L = 0, A = 1, W))$pred[, 1]
    m00  <- predict(nuisance$fitm, newdata = data.frame(Z, L = 0, A = 0, W))$pred[, 1]

    m <- nuisance$fitm$SL.predict[, 1]
    m1A <- A * m11 + (1 - A) * m10
    m0A <- A * m01 + (1 - A) * m00

    uA <- m1A * b1A + m0A * (1 - b1A)
    u1 <- m11 * b11 + m01 * (1 - b11)
    u0 <- m10 * b10 + m00 * (1 - b10)

    vout <- m * b / d
    sout <- m * b / d * g / e

    if(sd(vout) < .Machine$double.eps * 10) {
        v1 <- v0 <- rep(mean(vout), length(vout))
    } else {
        fitv <- mySL(
            Y = vout,
            X = data.frame(L, A, W),
            family = stats::gaussian(),
            SL.library = candidatesv,
            validRows = nuisance$valSets
        )
        v1 <- predict(fitv, newdata = data.frame(L = 1, A, W))$pred[, 1]
        v0 <- predict(fitv, newdata = data.frame(L = 0, A, W))$pred[, 1]
    }

    if(sd(sout) < .Machine$double.eps * 10) {
        s1 <- s0 <- rep(mean(sout), length(sout))
    } else {
        fits <- mySL(
            Y = sout,
            X = data.frame(L, A, W),
            family = stats::gaussian(),
            SL.library = candidatess,
            validRows = nuisance$valSets
        )
        s1 <- predict(fits, newdata = data.frame(L = 1, A, W))$pred[, 1]
        s0 <- predict(fits, newdata = data.frame(L = 0, A, W))$pred[, 1]
    }

    if(sd(uA) < .Machine$double.eps * 10) {
        ubar1 <- ubar0 <- rep(mean(uA), length(uA))
    } else {
        fitubar <- mySL(
            Y = uA,
            X = data.frame(A, W),
            family = stats::gaussian(),
            SL.library = candidatesubar,
            validRows = nuisance$valSets
        )
        ubar1 <- predict(fitubar, newdata = data.frame(A = 1, W))$pred[, 1]
        ubar0 <- predict(fitubar, newdata = data.frame(A = 0, W))$pred[, 1]
    }

    ubarA  <- A * ubar1 + (1 - A) * ubar0
    q1    <- ubar1 - ubar0

    if(sd(u1 - u0) < .Machine$double.eps * 10) {
        q2  <- rep(mean(u1 - u0), length(u1))
    } else {
        fitq2 <- mySL(
            Y = u1 - u0,
            X = data.frame(W),
            family = stats::gaussian(),
            SL.library = candidatesq,
            validRows = nuisance$valSets
        )
        q2  <- fitq2$SL.predict[, 1]
    }

    g1delta <- gdelta1(g1, delta)
    gdelta <- A * g1delta + (1 - A) * (1 - g1delta)

    HD <- b / d * (1 - gdelta / e)
    HI <- b / d * gdelta * (1 / e -  1 / g)
    KD <- v1 - v0 - gdelta / g * (s1 - s0)
    KI <- gdelta / g * (s1 - s0 - v1 + v0)
    MD <- - g1delta * (1 - g1delta) / (g1 * (1 - g1)) * q2
    MI <- g1delta * (1 - g1delta) / (g1 * (1 - g1)) * (q2 - q1)
    J  <- - gdelta / g

    de <- ubar1 * g1 + ubar0 * (1 - g1) - (u1 * g1delta + u0 * (1 - g1delta))
    ie <- (u1 - ubar1) * g1delta + (u0 - ubar0) * (1 - g1delta)
    eifD <- HD * (Y - m) + KD * (L - b1A) + MD * (A - g1) + (uA - ubarA) + de
    eifI <- HI * (Y - m) + KI * (L - b1A) + MI * (A - g1) + J * (uA - ubarA) + ie

    osde <- mean(eifD)
    osie <- mean(eifI)
    seosde <- sd(eifD) / sqrt(n)
    seosie <- sd(eifI) / sqrt(n)

    ## now, compute the TMLE
    stopcrit <- FALSE
    iter <- 1

    ## iterative TMLE
    while (!stopcrit) {
        tiltm <- glm(Y ~ 0 + offset(qlogis(bound(m)))   + HD + HI, family = binomial())
        tiltb <- glm(L ~ 0 + offset(qlogis(bound(b1A))) + KD + KI, family = binomial())
        tiltg <- glm(A ~ 0 + offset(qlogis(bound(g1)))  + MD + MI, family = binomial())

        m   <- predict(tiltm, type = 'response')
        b1A <- predict(tiltb, type = 'response')
        g1  <- predict(tiltg, type = 'response')

        HD11 <- b11 / d11 * (1 - g1delta / e1)
        HI11 <- b11 / d11 * g1delta * (1 / e1 -  1 / g1)
        HD10 <- b10 / d10 * (1 - (1 - g1delta) / (1 - e1))
        HI10 <- b10 / d10 * (1 - g1delta) * (1 / (1 - e1) -  1 / (1 - g1))

        HD01 <- (1 - b11) / (1 - d11) * (1 - g1delta / e1)
        HI01 <- (1 - b11) / (1 - d11) * g1delta * (1 / e1 -  1 / g1)
        HD00 <- (1 - b10) / (1 - d10) * (1 - (1 - g1delta) / (1 - e1))
        HI00 <- (1 - b10) / (1 - d10) * (1 - g1delta) * (1 / (1 - e1) -  1 / (1 - g1))

        m11 <- plogis(qlogis(bound(m11)) + coef(tiltm)[1] * HD11 + coef(tiltm)[2] * HI11)
        m10 <- plogis(qlogis(bound(m10)) + coef(tiltm)[1] * HD10 + coef(tiltm)[2] * HI10)
        m01 <- plogis(qlogis(bound(m01)) + coef(tiltm)[1] * HD01 + coef(tiltm)[2] * HI01)
        m00 <- plogis(qlogis(bound(m00)) + coef(tiltm)[1] * HD00 + coef(tiltm)[2] * HI00)

        g <- A * g1 + (1 - A) * (1 - g1)
        b <- L * b1A + (1 - L) * (1 - b1A)
        g1delta <- gdelta1(g1, delta)
        gdelta <- A * g1delta + (1 - A) * (1 - g1delta)

        HD <- b / d * (1 - gdelta / e)
        HI <- b / d * gdelta * (1 / e -  1 / g)
        KD <- v1 - v0 - gdelta / g * (s1 - s0)
        KI <- gdelta / g * (s1 - s0 - v1 + v0)
        MD <- - g1delta * (1 - g1delta) / (g1 * (1 - g1)) * q2
        MI <- g1delta * (1 - g1delta) / (g1 * (1 - g1)) * (q2 - q1)

        de <- ubar1 * g1 + ubar0 * (1 - g1) - (u1 * g1delta + u0 * (1 - g1delta))
        ie <- (u1 - ubar1) * g1delta + (u0 - ubar0) * (1 - g1delta)

        eifDp <- HD * (Y - m) + KD * (L - b1A) + MD * (A - g1)
        eifIp <- HI * (Y - m) + KI * (L - b1A) + MI * (A - g1)

        ## iterate iterator
        iter <- iter + 1
        ## note: interesting stopping criterion
        stopcrit <- max(abs(c(mean(eifDp), mean(eifIp)))) <
            max(c(sd(eifDp), sd(eifIp))) * log(n) / n | iter > 6
    }

    J   <- - gdelta / g
    J1  <- - g1delta / g1
    J0  <- - (1 - g1delta) / (1 - g1)

    m1A <- A * m11 + (1 - A) * m10
    m0A <- A * m01 + (1 - A) * m00

    uA <- m1A * b1A + m0A * (1 - b1A)
    u1 <- m11 * b11 + m01 * (1 - b11)
    u0 <- m10 * b10 + m00 * (1 - b10)

    tiltu <- glm(uA ~ offset(qlogis(bound(ubarA))) + J, family = binomial())
    ubar1 <- plogis(coef(tiltu)[1] + qlogis(bound(ubar1)) + coef(tiltu)[2] * J1)
    ubar0 <- plogis(coef(tiltu)[1] + qlogis(bound(ubar0)) + coef(tiltu)[2] * J0)
    ubarA  <- A * ubar1 + (1 - A) * ubar0

    de <- ubar1 * g1 + ubar0 * (1 - g1) - (u1 * g1delta + u0 * (1 - g1delta))
    ie <- (u1 - ubar1) * g1delta + (u0 - ubar0) * (1 - g1delta)

    eifD <- HD * (Y - m) + KD * (L - b1A) + MD * (A - g1) + (uA - ubarA) + de
    eifI <- HI * (Y - m) + KI * (L - b1A) + MI * (A - g1) + J * (uA - ubarA) + ie

    tmlede <- mean(de)
    tmleie <- mean(ie)
    setmlede <- sd(eifD) / sqrt(n)
    setmleie <- sd(eifI) / sqrt(n)

    out <- data.frame(
        parameter = c('DE', 'IE', 'DE', 'IE'),
        estimator = c('OS', 'OS', 'TMLE', 'TMLE'),
        estimate  = c(osde, osie, tmlede, tmleie),
        ses       = c(seosde, seosie, setmlede, setmleie),
        n         = n,
        seed      = seed,
        type      = type)

    return(out)
}


subroutine stl(y,n,np,ns,nt,nl,isdeg,itdeg,ildeg,nsjump,ntjump,nljump,ni,no,rw,
	season,trend,work)

integer n, np, ns, nt, nl, isdeg, itdeg, ildeg, nsjump, ntjump, nljump, ni, no, k
integer newns, newnt, newnl, newnp
real y(n), rw(n), season(n), trend(n), work(n+2*np,5)
logical userw

userw = .false.
k = 0
do i = 1,n
	trend(i) = 0.0
newns = max0(3,ns)
newnt = max0(3,nt)
newnl = max0(3,nl)
newnp = max0(2,np)
if(mod(newns,2)==0) newns = newns + 1	#make odd
if(mod(newnt,2)==0) newnt = newnt + 1
if(mod(newnl,2)==0) newnl = newnl + 1
repeat {
	call onestp(y,n,newnp,newns,newnt,newnl,isdeg,itdeg,ildeg,nsjump,ntjump,nljump,
	ni,userw,rw,season, trend, work)
	k = k+1
	if(k>no) break
	do i = 1,n
		work(i,1) = trend(i)+season(i)
	call rwts(y,n,work(1,1),rw)
	userw = .true.
	}
if (no<=0)
	do i = 1,n
		rw(i) = 1.0
return
end

subroutine ess(y,n,len,ideg,njump,userw,rw,ys,res)

integer n, len, ideg, njump, newnj, nleft, nright, nsh, k, i, j
real y(n), rw(n), ys(n), res(n), delta
logical ok, userw

if(n<2) { ys(1) = y(1); return }
newnj = min0(njump, n-1)
if(len>=n) {	#len > or = n
	nleft = 1
	nright = n
	do i = 1,n,newnj {
		call est(y,n,len,ideg,float(i),ys(i),nleft,nright,res,userw,rw,ok)
		if(!ok) ys(i) = y(i)
		}
	}
else if(newnj==1) {	# newnj equal to one, len less than n
	nsh = (len+1)/2
	nleft = 1
	nright = len
	do i = 1,n {	# fitted value at i
		if(i>nsh && nright!=n) {
			nleft = nleft+1
			nright = nright+1
			}
		call est(y,n,len,ideg,float(i),ys(i),nleft,nright,res,userw,rw,ok)
		if(!ok) ys(i) = y(i)
		}
	}
else { # newnj greater than one, len less than n
	nsh = (len+1)/2
	do i = 1,n,newnj {	# fitted value at i
		if(i<nsh) {
			nleft = 1
			nright = len
			}
		else if(i>=n-nsh+1) {
			nleft = n-len+1
			nright = n
			}
		else {
			nleft = i-nsh+1
			nright = len+i-nsh
			}
		call est(y,n,len,ideg,float(i),ys(i),nleft,nright,res,userw,rw,ok)
		if(!ok) ys(i) = y(i)
		}
	}
if(newnj!=1){
	do i = 1,n-newnj,newnj {
		delta = (ys(i+newnj)-ys(i))/float(newnj)
		do j = i+1,i+newnj-1
			ys(j) = ys(i)+delta*float(j-i)
		}
	k = ((n-1)/newnj)*newnj+1
	if(k!=n) {
		call est(y,n,len,ideg,float(n),ys(n),nleft,nright,res,userw,rw,ok)
		if(!ok) ys(n) = y(n)
		if(k!=n-1) {
			delta = (ys(n)-ys(k))/float(n-k)
			do j = k+1,n-1
				ys(j) = ys(k)+delta*float(j-k)
			}
		}
	}
return
end

subroutine est(y,n,len,ideg,xs,ys,nleft,nright,w,userw,rw,ok)

integer n, len, ideg, nleft, nright, j
real y(n), w(n), rw(n), xs, ys, range, h, h1, h9, a, b, c, r
logical userw,ok

range = float(n)-float(1)
h = amax1(xs-float(nleft),float(nright)-xs)
if (len>n) h = h+float((len-n)/2)
h9 = .999*h
h1 = .001*h
# compute weights
a = 0.0
do j = nleft,nright {
	w(j) = 0.
	r = abs(float(j)-xs)
	if (r<=h9) {
		if (r<=h1) w(j) = 1.
		else w(j) = (1.0-(r/h)**3)**3
		if (userw) w(j) = rw(j)*w(j)
		a = a+w(j)
		}
	}
if (a<=0.0)
	ok = .false.
else {	# weighted least squares
	ok = .true.
	do j = nleft,nright	# make sum of w(j) == 1
		w(j) = w(j)/a
	if ((h>0.)&(ideg>0)) {	# use linear fit
		a = 0.0
		do j = nleft,nright	# weighted center of x values
			a = a+w(j)*float(j)
		b = xs-a
		c = 0.0
		do j = nleft,nright
			c = c+w(j)*(float(j)-a)**2
		if (sqrt(c)>.001*range) {
			b = b/c
# points are spread out enough to compute slope
			do j = nleft,nright
				w(j) = w(j)*(b*(float(j)-a)+1.0)
			}
		}
	ys = 0.0
	do j = nleft,nright
		ys = ys+w(j)*y(j)
	}
return
end

subroutine fts(x,n,np,trend,work)

integer n, np
real x(n), trend(n), work(n)

call ma(x,n,np,trend)
call ma(trend,n-np+1,np,work)
call ma(work,n-2*np+2,3,trend)
return
end

subroutine ma(x, n, len, ave)

integer n, len, i, j, k, m, newn
real x(n), ave(n), flen, v

newn = n-len+1
flen = float(len)
v = 0.0
# get the first average
do i = 1,len
	v = v+x(i)
ave(1) = v/flen
if (newn>1) {
	k = len
	m = 0
	do j = 2, newn {
# window down the array
		k = k+1
		m = m+1
		v = v-x(m)+x(k)
		ave(j) = v/flen
	}
}
return
end

subroutine onestp(y,n,np,ns,nt,nl,isdeg,itdeg,ildeg,nsjump,ntjump,nljump,ni,
	userw,rw,season,trend,work)

integer n,ni,np,ns,nt,nsjump,ntjump,nl,nljump,isdeg,itdeg,ildeg
real y(n),rw(n),season(n),trend(n),work(n+2*np,5)
logical userw

do j = 1,ni {
	do i = 1,n
		work(i,1) = y(i)-trend(i)
	call ss(work(1,1),n,np,ns,isdeg,nsjump,userw,rw,work(1,2),work(1,3),work(1,4),
		work(1,5),season)
	call fts(work(1,2),n+2*np,np,work(1,3),work(1,1))
	call ess(work(1,3),n,nl,ildeg,nljump,.false.,work(1,4),work(1,1),work(1,5))
	do i = 1,n
		season(i) = work(np+i,2)-work(i,1)
	do i = 1,n
		work(i,1) = y(i)-season(i)
	call ess(work(1,1),n,nt,itdeg,ntjump,userw,rw,trend,work(1,3))
	}
return
end

subroutine rwts(y,n,fit,rw)

integer mid(2), n
real y(n), fit(n), rw(n), cmad, c9, c1, r

do i = 1,n
	rw(i) = abs(y(i)-fit(i))
mid(1) = n/2+1
mid(2) = n-mid(1)+1
call psort(rw,n,mid,2)
cmad = 3.0*(rw(mid(1))+rw(mid(2)))	#6 * median abs resid
c9 = .999*cmad
c1 = .001*cmad
do i = 1,n {
	r = abs(y(i)-fit(i))
	if (r<=c1) rw(i) = 1.
	else if (r<=c9) rw(i) = (1.0-(r/cmad)**2)**2
	else rw(i) = 0.
	}
return
end

subroutine ss(y,n,np,ns,isdeg,nsjump,userw,rw,season,work1,work2,work3,work4)

integer n, np, ns, isdeg, nsjump, nright, nleft, i, j, k
real y(n), rw(n), season(n+2*np), work1(n), work2(n), work3(n), work4(n), xs
logical userw,ok

for(j=1; j<=np; j=j+1){
	k = (n-j)/np+1
	do i = 1,k
		work1(i) = y((i-1)*np+j)
	if(userw)
		do i = 1,k
			work3(i) = rw((i-1)*np+j)
	call ess(work1,k,ns,isdeg,nsjump,userw,work3,work2(2),work4)
	xs = 0
	nright = min0(ns,k)
	call est(work1,k,ns,isdeg,xs,work2(1),1,nright,work4,userw,work3,ok)
	if(!ok) work2(1) = work2(2)
	xs = k+1
	nleft = max0(1,k-ns+1)
	call est(work1,k,ns,isdeg,xs,work2(k+2),nleft,k,work4,userw,work3,ok)
	if(!ok) work2(k+2) = work2(k+1)
	do m = 1,k+2
		season((m-1)*np+j) = work2(m)
	}
return
end
subroutine stlez(y, n, np, ns, isdeg, itdeg, robust, no, rw, season, trend, work)

logical robust
integer n, i, j, np, ns, no, nt, nl, ni, nsjump, ntjump, nljump, newns, newnp
integer isdeg, itdeg, ildeg
real y(n), rw(n), season(n), trend(n), work(n+2*np,7)
real maxs, mins, maxt, mint, maxds, maxdt, difs, dift

ildeg = itdeg
newns = max0(3,ns)
if(mod(newns,2)==0) newns = newns+1
newnp = max0(2,np)
nt = (1.5*newnp)/(1 - 1.5/newns) + 0.5
nt = max0(3,nt)
if(mod(nt,2)==0) nt = nt+1
nl = newnp
if(mod(nl,2)==0) nl = nl+1
if(robust) ni = 1
else ni = 2
nsjump = max0(1,int(float(newns)/10 + 0.9))
ntjump = max0(1,int(float(nt)/10 + 0.9))
nljump = max0(1,int(float(nl)/10 + 0.9))
do i = 1,n
	trend(i) = 0.0
call onestp(y,n,newnp,newns,nt,nl,isdeg,itdeg,ildeg,nsjump,ntjump,nljump,ni,
	.false.,rw,season,trend,work)
no = 0
if(robust){
	for(j=1; j<=15; j=j+1){	#robustness iterations
		do i = 1,n{	#initialize for testing
			work(i,6) = season(i)
			work(i,7) = trend(i)
			work(i,1) = trend(i)+season(i)
			}
		call rwts(y,n,work(1,1),rw)
		call onestp(y, n, newnp, newns, nt, nl, isdeg, itdeg, ildeg, nsjump,
			ntjump, nljump, ni, .true., rw, season, trend, work)
		no = no+1
		maxs = work(1,6)
		mins = work(1,6)
		maxt = work(1,7)
		mint = work(1,7)
		maxds = abs(work(1,6) - season(1))
		maxdt = abs(work(1,7) - trend(1))
		do i = 2,n{
			if(maxs<work(i,6)) maxs = work(i,6)
			if(maxt<work(i,7)) maxt = work(i,7)
			if(mins>work(i,6)) mins = work(i,6)
			if(mint>work(i,7)) mint = work(i,7)
			difs = abs(work(i,6) - season(i))
			dift = abs(work(i,7) - trend(i))
			if(maxds<difs) maxds = difs
			if(maxdt<dift) maxdt = dift
			}
		if((maxds/(maxs-mins)<.01) & (maxdt/(maxt-mint)<.01)) break
		}
	}
if(!robust){
	do i = 1,n
		rw(i) = 1.0
	}
return
end
subroutine psort(a,n,ind,ni)
real a(n)
integer n,ind(ni),ni
integer indu(16),indl(16),iu(16),il(16),p,jl,ju,i,j,m,k,ij,l
real t,tt
if (n<0||ni<0) return #ERROR(number of items<0)
if(n<2 | ni==0) return
jl = 1
ju = ni
indl(1) = 1
indu(1) = ni
#  arrays indl, indu keep account of the portion of ind related to the
#  current segment of data being ordered.
i = 1
j = n
m = 1
repeat {
	if (i<j) go to 10
	repeat {
		m = m-1
		if (m==0) break 2
		i = il(m)
		j = iu(m)
		jl = indl(m)
		ju = indu(m)
		if (jl<=ju) {
			while (j-i>10) {
#  first order a(i),a(j),a((i+j)/2), and use median to split the data
				10  k = i
				ij = (i+j)/2
				t = a(ij)
				if (a(i)>t) {
					a(ij) = a(i)
					a(i) = t
					t = a(ij)
					}
				l = j
				if (a(j)<t) {
					a(ij) = a(j)
					a(j) = t
					t = a(ij)
					if (a(i)>t) {
						a(ij) = a(i)
						a(i) = t
						t = a(ij)
						}
					}
				repeat {
					l = l-1
					if (a(l)<=t) {
						tt = a(l)
						repeat
#  split the data into a(i to l).lt.t, a(k to j).gt.t
							k = k+1
							until(a(k)>=t)
						if (k>l) break
						a(l) = a(k)
						a(k) = tt
						}
					}
				indl(m) = jl
				indu(m) = ju
				p = m
				m = m+1
#  split the larger of the segments
				if (l-i<=j-k) {
					il(p) = k
					iu(p) = j
					j = l
					repeat {
						if (jl>ju) next 3
						if (ind(ju)<=j) break
						ju = ju-1
						}
					indl(p) = ju+1
					}
				else {
					il(p) = i
					iu(p) = l
					i = k
					repeat {
#  skip all segments not corresponding to an entry in ind
						if (jl>ju) next 3
						if (ind(jl)>=i) break
						jl = jl+1
						}
					indu(p) = jl-1
					}
				}
			if (i==1) break
			i = i-1
			repeat {
				i = i+1
				if (i==j) break
				t = a(i+1)
				if (a(i)>t) {
					k = i
					repeat {
						a(k+1) = a(k)
						k = k-1
						}
						until(t>=a(k))
					a(k+1) = t
					}
				}
			}
		}
	}
return
end


library(raster)
library(ggplot2)
library(rgdal)
library(tmap)
library(sf)
library(dplyr)
library(spData)
library(spDataLarge)
library(sp)
library(rgeos)
library(xlsx)

setwd("C:/working/COVID19/map_outcome/")
#admin41 < -shapefile("C:/working/COVID19/final_data_for_mapping/spatial_data/old/np_municipality_utm_population.shp")
#admin4_indicators < -shapefile("C:/working/COVID19/final_data_for_mapping/spatial_data/old/np_admin_3_4_all_indicators_may13_utm.shp")
admin4 < -shapefile("C:/working/COVID19/final_data_for_mapping/spatial_data/np_admin4_health_pop_all_indicators1.shp")

origCrs < -crs(admin4)
#Convert to utm 45 N
admin4 < -spTransform(admin4, CRS("+init=epsg:32645"))

#as.integer(admin4 @data$EXP) < -admin4_indicators @data$EXP
admin4$Density_norm < -(admin4$Density / max(admin4$Density)) * 100

#quarantine < -read.xlsx("C:/working/COVID19/final_data_for_mapping/COVID_DATA_total_cases.xlsx", sheetName = 'Quarantine', header = TRUE)

#covid_case < -read.xlsx("C:/working/COVID19/final_data_for_mapping/COVID_DATA_total_cases.xlsx", sheetName = 'COVID_Cases', header = TRUE)

# # # # # # # # # # # # # #-- -- --precovid scenario # # # # # # # # # # # # # # # # # # # # # # # # # # # # # #

quarantine < -read.xlsx("C:/working/COVID19/final_data_for_mapping/COVID_DATA_zero_case_scenario.xlsx", sheetName = 'Quarantine', header = TRUE)
covid_case < -read.xlsx("C:/working/COVID19/final_data_for_mapping/COVID_DATA_zero_case_scenario.xlsx", sheetName = 'COVID_Cases', header = TRUE)

#Excluse all cases older than 90 days
dt_diff < -as.double(Sys.Date() - covid_case$Date)
valid < -which(dt_diff < 90)
covid_case < -covid_case[valid, ]

a < -!is.na(covid_case$Total_case)
covid_case < -covid_case[a, ]

a < -!is.na(quarantine$Quarantine)
quarantine < -quarantine[a, ]

# # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # #Methods # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # #

regional_imp < - function (admin4) {
  admin4 @data$r_imp < -0
  admin4 @data$food < -0
  for (i in 1: length(admin4$Max_Paddy_)) {
    admin4 @data$food[i] < -max(admin4$Max_Paddy_[i], admin4$Max_Maize_[i])
    admin4 @data$r_imp[i] < -max(admin4 @data$food[i], as.numeric(admin4$SCN[i]))
  }
  return (admin4)
}

#Compute ACS is component of PCS componentof ACS
acs_value < - function (admin4, total_cases) {
  admin4 @data$computed_pcs = 0
  length < -length(admin4$PALIKA)

  for (ad4_index in 1: length) {

    #c7 = number of cases
    #D8 = total population
    if (admin4$Population[ad4_index] != 0) {
      if (admin4$cases[ad4_index] == 0) {
        admin4 @data$computed_pcs[ad4_index] < -0
      } else {

        #admin4 @data$computed_pcs[ad4_index] = 100 + (log(admin4$cases[ad4_index] / as.numeric(admin4$Population[ad4_index])) * 50 / (-log(1 / as.numeric(admin4$Population[ad4_index]))))
        a < -admin4$cases[ad4_index]
        b < -as.numeric(admin4$Population[ad4_index]) / 4.6
        if (a < b) {
          admin4 @data$computed_pcs[ad4_index] = 100 - log(a / b) * 50 / (log(1 / b))
        } else {
          admin4 @data$computed_pcs[ad4_index] = 100
        }

      }
    } else {
      admin4 @data$computed_pcs[ad4_index] < -0
    }

    '
    prop_active_cases < -admin4$cases[ad4_index] / total_cases
    if (admin4$Population[ad4_index] != 0) {
      prop_ppl < -admin4$cases[ad4_index] / admin4$Population[ad4_index]
    } else {
      admin4 @data$computed_pcs[ad4_index] < -0
    }

    if (prop_ppl == 0) {
      admin4 @data$computed_acs[ad4_index] < -0
    } else if (prop_ppl < 0.001) {
      admin4 @data$computed_acs[ad4_index] < -50 + 0.5 * prop_active_cases
    } else if (prop_ppl < 0.01) {
      admin4 @data$computed_acs[ad4_index] < -60 + 0.4 * prop_active_cases
    } else if (prop_ppl < 0.1) {
      admin4 @data$computed_acs[ad4_index] < -80 + 0.2 * prop_active_cases
    } else if (prop_ppl < 1) {
      admin4 @data$computed_acs[ad4_index] < -90 + 0.1 * prop_active_cases
    } else if (prop_ppl > 1) {
      admin4 @data$computed_acs[ad4_index] < -100
    }
    print("...................")
    '
  }
  return (admin4)

}

#Neighborhood risk transfer computation

neightborhood_weight < - function (admin4, infected_admin) {
  #admin4 is the shape file having the administrative uniits of full extension.
  #infected_admin < -is the admin list which has the quarentined or infected cases
  for (i in 1: length(infected_admin)) {
    infected_palika < -subset(admin4, index == infected_admin[i])
    #Analysis with 10 km buffer
    buffer_10km < -buffer(infected_palika, width = 1000)
    clip_10km < -intersect(admin4, buffer_10km)

    #Update the risk within 10 km buffer
    # the risk is reduced to half
    if the last
    case is greater than 60 days and 0
    if it is greater than 90 days.
    poly_to_update < -clip_10km$index
    for (index_to_update in 1: length(poly_to_update)) {
      if (!is.na(admin4$Latest_date[poly_to_update[index_to_update]])) {
        dt_dif < -as.double(Sys.Date() - admin4$Latest_date[poly_to_update[index_to_update]])
        if (dt_dif > 90) {
          risk_existing < -0
        } else if (dt_dif > 60) {
          risk_existing < -as.numeric(admin4$cases[poly_to_update[index_to_update]]) / 2
        } else {
          risk_existing < -as.numeric(admin4$cases[poly_to_update[index_to_update]])
        }
      } else {
        risk_existing < -0
      }
      if (!is.na(admin4$Latest_date[infected_admin[i]])) {
        dt_dif < -as.double(Sys.Date() - admin4$Latest_date[infected_admin[i]])
        if (dt_dif > 90) {
          risk_neighbur < -0
        } else if (dt_dif > 60) {
          risk_neighbur < -as.numeric(admin4$cases[infected_admin[i]]) / 2
        } else {
          risk_neighbur < -as.numeric(admin4$cases[infected_admin[i]])
        }
      } else {
        risk_neighbur < -0
      }

      if (!is.na(risk_existing)) {
        if (risk_neighbur > risk_existing) {
          admin4$cases[poly_to_update[index_to_update]] < -risk_neighbur / 2
        }

      } else {
        admin4$cases[poly_to_update[index_to_update]] < -risk_existing
      }

    }

    #Analysis with 10 km buffer
    buffer_20km < -buffer(infected_palika, width = 2000)
    clip_20km < -intersect(admin4, buffer_20km)
    #Update with 10 km buffer
    poly_to_update < -setdiff(clip_20km$index, clip_10km$index)
    if (length(poly_to_update) > 0) {
      for (index_to_update in 1: length(poly_to_update)) {
        if (!is.na(admin4$Latest_date[poly_to_update[index_to_update]])) {
          dt_dif < -as.double(Sys.Date() - admin4$Latest_date[poly_to_update[index_to_update]])
          if (dt_dif > 90) {
            risk_existing < -0
          } else if (dt_dif > 60) {
            risk_existing < -as.numeric(admin4$cases[poly_to_update[index_to_update]]) / 2
          } else {
            risk_existing < -as.numeric(admin4$cases[poly_to_update[index_to_update]])
          }
        } else {
          risk_existing < -0
        }
        if (!is.na(admin4$Latest_date[infected_admin[i]])) {
          dt_dif < -as.double(Sys.Date() - admin4$Latest_date[infected_admin[i]])
          if (dt_dif > 90) {
            risk_neighbur < -0
          } else if (dt_dif > 60) {
            risk_neighbur < -as.numeric(admin4$cases[infected_admin[i]]) / 2
          } else {
            risk_neighbur < -as.numeric(admin4$cases[infected_admin[i]])
          }
        } else {
          risk_neighbur < -0
        }

        if (!is.na(risk_existing)) {
          if (risk_neighbur > risk_existing) {
            admin4$cases[poly_to_update[index_to_update]] < -risk_neighbur / 2
          }

        } else {
          admin4$cases[poly_to_update[index_to_update]] < -risk_existing
        }

      }
      'for (index_to_update in 1: length(poly_to_update)){
      risk_existing < -as.numeric(admin4$cases[poly_to_update[index_to_update]])
      risk_neighbur < -as.numeric(admin4$cases[infected_admin[i]]) / 2
      if (!is.na(risk_existing)) {
        if (risk_neighbur > risk_existing) {
          admin4$cases[poly_to_update[index_to_update]] < -risk_neighbur / 2
        }

      } else {
        admin4$cases[poly_to_update[index_to_update]] < -risk_existing
      }

    }
    '
  }
}
return (admin4)
}

# # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # #Methods # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # #3

active_cases_district <- covid_case %>%

  group_by(DISTRICT) %>%

  summarise(total_case = sum(Total_case))

active_cases < -covid_case % > %
  group_by(DISTRICT, PALIKA) % > %
  summarise(total_case = sum(Total_case), latest_date = (max(Date)))

names(active_cases) < -c("DISTRICT", "PALIKA", "Infected", "Latest_date")

admin4 < -merge(admin4, active_cases, by = c("DISTRICT", "PALIKA"), all = TRUE)

active_quarantine < -quarantine % > %
  group_by(District) % > %
  summarise(total_quarantine = sum(Quarantine))

admin4$Quarantine < -0
for (i in 1: length(active_quarantine$District)) {
  index < -which(admin4$DISTRICT == active_quarantine$District[i])
  admin4$Quarantine[index] < -active_quarantine$total_quarantine[i]

}

#covid_infected < -subset(covid_case, subset = Infected. > 1)
#infected_admin < -data.frame(covid_infected$Municipality, covid_infected$Ward, covid_infected$Infected.)
#names(infected_admin) < -c("Municipality", "Ward", "Infected")
#names(covid_case) < -c("Date", "District", "PALIKA", "WARD", "Infected", "Recovered", "Quarantine", "Isolation")
#admin4 < -merge(admin4, covid_case, by = c("PALIKA", "WARD"), all = TRUE)
admin4$Infected[is.na(admin4$Infected)] < -0
admin4$Population[is.na(admin4$Population)] < -10000000

total_active_cases < -sum(admin4$Infected[which(admin4$Infected > 0)])
total_quarentined < -sum(admin4$Quarantine[which(admin4$Quarantine > 0)])
#total_isolated < -sum(covid_case$Isolation[which(covid_case$Isolation > 0)])

admin4 @data$index[1] < -999
lnth < -length(admin4 @data$PROVINCE)
admin4 @data$index[1: lnth] < -1: lnth
infected_admin < -which(admin4$Infected > 0)
quarantine_admin < -which(admin4$Quarantine > 0)

#-- -- -- -- -- -- -- -- -- -- -- -- -- - Infected risk transfer
admin4 @data$cases < -0
admin4 @data$cases < -admin4 @data$Infected
admin4 < -neightborhood_weight(admin4, infected_admin)
admin4 @data$Infected < -admin4 @data$cases

#-- -- -- -- -- -- -- -- -- --Quarantine risk transfer
admin4 @data$cases < -0
admin4 @data$cases < -admin4 @data$Quarantine
admin4 < -neightborhood_weight(admin4, quarantine_admin)
admin4 @data$Quarantine < -admin4 @data$cases

#-- -- -- -- -- -- -- -- -- -- --Compute pcs(Positive
  case score)
admin4 @data$cases < -0
admin4 @data$cases < -admin4 @data$Infected
admin4 < -acs_value(admin4, total_active_cases)
admin4 @data$pcs < -admin4 @data$computed_pcs

#-- -- -- -- -- -- -- -- -- -- -- --Compute QNT(Quarantined people score) risk score
admin4 @data$cases < -0
admin4 @data$cases < -admin4 @data$Quarantine
admin4 < -acs_value(admin4, total_quarentined)
admin4 @data$qnt < -admin4 @data$computed_pcs

admin4 < -regional_imp(admin4)

admin4 @data$CTR < -0
admin4 @data$CTR < -0.6 * admin4$pcs + 0.2 * admin4$Density_norm + 0.1 * admin4$qnt + 0.1 * as.numeric(admin4$EXP)

admin4$TRS_r_pp < -0
admin4$TRS_r_pp < -0.8 * admin4$CTR + 0.2 * ((0.6 * admin4$r_PHR_pp + 0.4 * admin4$SER))

admin4$TRS_r_t < -0
admin4$TRS_r_t < -0.8 * admin4$CTR + 0.2 * (0.6 * (admin4$r_PHR_t + 0.4 * admin4$SER))

admin4$local_leve < -as.numeric(substr(admin4$local_leve, start = 1, stop = 5))

admin4 < -spTransform(admin4, CRS("+proj=longlat +datum=WGS84"))

# # # # # # # # # # # # # # # # # # # # # # # # # # #-- -- -- -- -- - Map writing-- -- -- -- -- -- -- -- --# # # # # # # # # # # # # # # # # # # # # # # #
#writeOGR(admin4, ".", "__covid19_nov_02_risk", driver = "ESRI Shapefile")
writeOGR(admin4, ".", "___precovid", driver = "ESRI Shapefile")

# # # # # # # # # # # # # # # # # # # # # # # # # # #-- -- -- -- -- - Excel_sheet-- -- -- -- -- -- -- -- --# # # # # # # # # # # # # # # # # # # # # # # #
req_data < -data.frame(admin4$DISTRICT, admin4$GaPa_NaPa, admin4$Type_GN, admin4$lat, admin4$long, admin4$local_leve, admin4$CTR, admin4$TRS_r_t)
index_na < -which(!is.na(req_data$admin4.local_leve))
req_data < -req_data[index_na, ]
dup_dt < -duplicated(req_data$admin4.local_leve)
req_data < -req_data[!dup_dt, ]
names(req_data) < -c("district_name", "gapa_napa", "gapa_napa_type", "lat", "long", "code", "ctr", "trs")
#write.csv(req_data, "__covid19_nov_02_risk.csv")
write.csv(req_data, "___precovid.csv")

#Overall computatioin


##############################################################################################################################################################################
#
# Filename: TDGEtest.r
# Description: Testing for differential expression.
# Author: Viktorian Miok
# Last modified: 29-11-2012
#
############################################################################################################################################################################################

# clear all.
rm(list=ls())
# set memory size to maximum.
memory.size(4000)

library(tigaR)
data(GEhpv3)
data(CNhpv3R)
setwd("N:/Cervical Cancer Data/tigaR analysis")
load("GeneExpr-RelativeCopyNumber_chr3_matching_overlapPlus.RData")

#CNcervix3 <- copynumber(CNdata)

# Specify size of the experiment
numtp <- 8       # Number of time points
numgroup <- 4    # Number of cell lines
# Specify the splines
numKnots <- 2    # Number of knots for splines
deg <- 3         # Degree of the splines
# Specify number of cpus to use
numcpus2use <- 2
###################################################################################################################################################################################################
#        Function for creating design matrices
###################################################################################################################################################################################################
# numKnots: Number of knots for splines
# deg: Degree of the splines
# numtp: Number of time points
# numgroup: Number of groups (cell lines)
# DiffSpl: if TRUE every group (cell line) is explained with different spline, if FALSE same spline is used for all groups (cell lines)
# groupfac: cell line effect
# timefac: time effect
# ZSpline: Design matrix for low-rank thin-plate splines.
desMat <- GetDesign(numKnots=numKnots, deg=deg, numtp=numtp, numgroup=numgroup, DiffSpl=TRUE)
                           groupfac <- desMat$groupfac
                           timefac <- desMat$timefac
                           DsgGroup <- desMat$DsgGroup
                           ZSpline <- desMat$ZSpline
groupfacHPV <- factor(rep(1:2, each = 16))
setwd("N:/Cervical Cancer Data/tigaR analysis/Fitting")
########################################################################################################################################################################################################

###################################################################################################################################################################################################
#        Function of estimation of model hyper-parameters and parameters
###################################################################################################################################################################################################
# form: Defines the model formula, where groupfac, x and f() repesent cell line, copy number and (random) time effect, repsectively.
#       Combining these effects user have possibility to estimate hyper-parameters of  different models.
# dat: Gene expression data
# dat1: DNA copy number data, if model without copy number is considered effect dat1=NULL
# shrinkfixed: Shrink parameter of copy number using parametric prior which combine point mass at zero and Gaussian distribution, if not shrinkfixed=NULL
# shrinkrandom: Shrink parameters of random time effects using Gamma distribution as parametric prior, if not shrinkrandom=NULL
# shrinksigma: Shrink parameters of the errorusing Gamma distribution as parametric prior, if not shrinksigma=NULL
# mixtrand: Shrink random effect with parametri prior which combine point mass at zero and Gamma distribution, if not mixtrand=NULL
# ncpus: Number of cpus used for parallel computation, if ncpus is larger than actual cpus function will still run.
# addpackage: Additional package which will be shared among cpus.
# orthogonal: Orthogonalize spline design matrix onto copy number data, if not orthogonal=FALSE.
# shrink: if TRUE output will be standard INLA output required for ShrinkHyperPar function, if not than output have object necessar for further analysis.
###################################################################################################################################################################################################
#        Function of model fitting using estimated(shrunken) hyper-paramters
###################################################################################################################################################################################################
# shrinksimul: Object whcih contain shrunken estimates of hyper parameters
# fams: Assumed distribution of the data. If the data are microarray gene expression fams="gaussian".
#       For RNA-seq data fams="nb" and for estimating hyper parameters use ShrinkSeq function from ShrinkBayes package.
# multivar: Fit model multivariate
################################################################################
#            Model described by DNA copy number
################################################################################
form <- y ~ groupfac + x-1
shrinksimul <- ShrinkHyperPar(form=form, dat=GEhpv3, dat1=CNhpv3R, timefac=timefac, groupfac=groupfac, ZSpline=ZSpline,
                              shrinkfixed="x", shrinkrandom=NULL, shrinksigma=TRUE, mixtrand=FALSE,
                              ncpus=numcpus2use, addpackage=c("splines"), orthogonal=FALSE, shrink=TRUE)

CN <- FitIntAllShrink(forms=form, dat=GEhpv3, dat1=CNhpv3R, timefac=timefac, groupfac=groupfac, ZSpline=ZSpline,
                      fams="gaussian", shrinksimul=shrinksimul, ncpus=numcpus2use, orthogonal=FALSE, shrink=FALSE, multivar=FALSE, rho=0)

form <- y ~ groupfac-1
CL <- FitIntAllShrink(forms=form, dat=GEhpv3, dat1=NULL, timefac=timefac, groupfac=groupfac, ZSpline=ZSpline,
                      fams="gaussian", shrinksimul=shrinksimul, ncpus=numcpus2use, orthogonal=FALSE, shrink=FALSE, multivar=FALSE, rho=0)
save(CN, file="CN.RData")
save(CL, file="CL.RData")
rm(CN,CL)
################################################################################
#            Model described by time (splines)
################################################################################
form <- y ~ groupfac + f(timefac, model="z", Z=ZSpline, initial=3, prior="loggamma", param=c(1,0.00001))-1
shrinksimul <- ShrinkHyperPar(form=form, dat=GEhpv3, dat1=NULL,timefac=timefac, groupfac=groupfac, ZSpline=ZSpline,
                              shrinkfixed=NULL, shrinkrandom="timefac", shrinksigma=TRUE, mixtrand=FALSE,  # !!!!!!!!!! mixtrand=TRUE only when you use mixture of Gamma and point mass
                              ncpus=numcpus2use, addpackage=c("splines"), orthogonal=FALSE, shrink=TRUE)

diffSpl <- FitIntAllShrink(form, dat=GEhpv3, dat1=NULL, timefac=timefac, groupfac=groupfac, ZSpline=ZSpline,
                           fams="gaussian", shrinksimul=shrinksimul, ncpus=numcpus2use, orthogonal=FALSE, shrink=FALSE, multivar=FALSE, rho=0)
save(diffSpl, file="diffSpl.RData")
rm(diffSpl)
################################################################################
#            Model described by time (splines)
################################################################################
form <- y ~ groupfac + f(timefac, model="z", Z=ZSpline, initial=3, prior="loggamma", param=c(1,0.00001))-1
shrinksimul <- ShrinkHyperPar(form=form, dat=GEhpv3, dat1=NULL,timefac=timefac, groupfac=groupfac, ZSpline=ZSpline,
                              shrinkfixed=NULL, shrinkrandom="timefac", shrinksigma=TRUE, mixtrand=TRUE,  # !!!!!!!!!! mixtrand=TRUE only when you use mixture of Gamma and point mass
                              ncpus=numcpus2use, addpackage=c("splines"), orthogonal=FALSE, shrink=TRUE)

diffSplMix <- FitIntAllShrink(form, dat=GEhpv3, dat1=NULL, timefac=timefac, groupfac=groupfac, ZSpline=ZSpline,
                           fams="gaussian", shrinksimul=shrinksimul, ncpus=numcpus2use, orthogonal=FALSE, shrink=FALSE, multivar=FALSE, rho=0)
save(diffSplMix, file="diffSplMix.RData")
rm(diffSplMix)
################################################################################
#           Model integrating DNA copy number and time (splines)
################################################################################
form <- y ~ groupfac + x + f(timefac, model="z", Z=ZSpline, initial=3, prior="loggamma", param=c(1,0.00001))-1
shrinksimul <- ShrinkHyperPar(form=form, dat=GEhpv3, dat1=CNhpv3R, timefac=timefac, groupfac=groupfac, ZSpline=ZSpline,
                              shrinkfixed="x", shrinkrandom="timefac", shrinksigma=TRUE, mixtrand=FALSE,
                              ncpus=numcpus2use, addpackage=c("splines"), orthogonal=FALSE, shrink=TRUE)

CNdiffSpl <- FitIntAllShrink(form, dat=GEhpv3, dat1=CNhpv3R, timefac=timefac, groupfac=groupfac, ZSpline=ZSpline,
                             fams="gaussian", shrinksimul=shrinksimul, ncpus=numcpus2use, orthogonal=FALSE, shrink=FALSE, multivar=TRUE, rho=0.5)
save(CNdiffSpl, file="CNdiffSpl.RData")
rm(CNdiffSpl)
################################################################################
#           Model integrating DNA copy number and time (splines)
################################################################################    , shrinkaddfixed="x:timefac"
form <- y ~ groupfac + x + x:timefac + f(timefac, model="z", Z=ZSpline, initial=3, prior="loggamma", param=c(1,0.00001))-1
shrinksimul <- ShrinkHyperPar(form=form, dat=GEhpv3, dat1=CNhpv3R, timefac=timefac, groupfac=groupfac, ZSpline=ZSpline,
                              shrinkfixed="x", shrinkaddfixed="x:timefac", shrinkrandom="timefac", shrinksigma=TRUE, mixtrand=FALSE,
                              ncpus=numcpus2use, addpackage=c("splines"), orthogonal=FALSE, shrink=TRUE)

CNdiffIntSpl <- FitIntAllShrink(form, dat=GEhpv3, dat1=CNhpv3R, timefac=timefac, groupfac=groupfac, ZSpline=ZSpline,
                             fams="gaussian", shrinksimul=shrinksimul, ncpus=numcpus2use, orthogonal=FALSE, shrink=FALSE, multivar=TRUE, rho=0.5)
save(CNdiffIntSpl, file="CNdiffIntSpl.RData")
rm(CNdiffIntSpl)
################################################################################
#           Model integrating DNA copy number and time (splines)
################################################################################
form <- y ~ groupfac + x + f(timefac, model="z", Z=ZSpline, initial=3, prior="loggamma", param=c(1,0.00001))-1
shrinksimul <- ShrinkHyperPar(form=form, dat=GEhpv3, dat1=CNhpv3R, timefac=timefac, groupfac=groupfac, ZSpline=ZSpline,
                              shrinkfixed="x", shrinkrandom="timefac", shrinksigma=TRUE, mixtrand=FALSE,
                              ncpus=numcpus2use, addpackage=c("splines"), orthogonal=TRUE, shrink=TRUE)

CNdiffSplOrt <- FitIntAllShrink(form, dat=GEhpv3, dat1=CNhpv3R, timefac=timefac, groupfac=groupfac, ZSpline=ZSpline,
                             fams="gaussian", shrinksimul=shrinksimul, ncpus=numcpus2use, orthogonal=TRUE, shrink=FALSE, multivar=TRUE, rho=0.5)
save(CNdiffSplOrt, file="CNdiffSplOrt.RData")
rm(CNdiffSplOrt)
################################################################################
#           Model integrating DNA copy number and time (splines)
################################################################################
form <- y ~ groupfac + x + x:timefac + f(timefac, model="z", Z=ZSpline, initial=3, prior="loggamma", param=c(1,0.00001))-1
shrinksimul <- ShrinkHyperPar(form=form, dat=GEhpv3, dat1=CNhpv3R, timefac=timefac, groupfac=groupfac, ZSpline=ZSpline,
                              shrinkfixed="x", shrinkaddfixed="x:timefac", shrinkrandom="timefac", shrinksigma=TRUE, mixtrand=FALSE,
                              ncpus=numcpus2use, addpackage=c("splines"), orthogonal=TRUE, shrink=TRUE)

CNsameIntSplOrt <- FitIntAllShrink(form, dat=GEhpv3, dat1=CNhpv3R, timefac=timefac, groupfac=groupfac, ZSpline=ZSpline,
                             fams="gaussian", shrinksimul=shrinksimul, ncpus=numcpus2use, orthogonal=TRUE, shrink=FALSE, multivar=TRUE, rho=0.5)
save(CNsameIntSplOrt, file="CNsameIntSplOrt.RData")
rm(CNsameIntSplOrt)
################################################################################
#           HPV effect
################################################################################
form <- y ~ x + f(timefac, model="z", Z=ZSpline, initial=3, prior="loggamma", param=c(1,0.00001))-1
shrinksimul <- ShrinkHyperPar(form=form, dat=GEhpv3, dat1=CNhpv3R, timefac=timefac, groupfac=groupfac, ZSpline=ZSpline,
                              shrinkfixed="x", shrinkrandom="timefac", shrinksigma=TRUE, mixtrand=FALSE,
                              ncpus=numcpus2use, addpackage=c("splines"), orthogonal=TRUE, shrink=TRUE)

CNdiffSplOrtHPVno <- FitIntAllShrink(form, dat=GEhpv3, dat1=CNhpv3R, timefac=timefac, groupfac=groupfac, ZSpline=ZSpline,
                             fams="gaussian", shrinksimul=shrinksimul, ncpus=numcpus2use, orthogonal=TRUE, shrink=FALSE, multivar=TRUE, rho=0.5)
save(CNdiffSplOrtHPVno, file="CNdiffSplOrtHPVno.RData")
rm(CNdiffSplOrtHPVno)

form <- y ~ groupfacHPV + x + f(timefac, model="z", Z=ZSpline, initial=3, prior="loggamma", param=c(1,0.00001))-1
shrinksimul <- ShrinkHyperPar(form=form, dat=GEhpv3, dat1=CNhpv3R, timefac=timefac, groupfac=groupfacHPV, ZSpline=ZSpline,
                              shrinkfixed="x", shrinkrandom="timefac", shrinksigma=TRUE, mixtrand=FALSE,
                              ncpus=numcpus2use, addpackage=c("splines"), orthogonal=TRUE, shrink=TRUE)

CNdiffSplOrtHPV <- FitIntAllShrink(form, dat=GEhpv3, dat1=CNhpv3R, timefac=timefac, groupfac=groupfacHPV, ZSpline=ZSpline,
                             fams="gaussian", shrinksimul=shrinksimul, ncpus=numcpus2use, orthogonal=TRUE, shrink=FALSE, multivar=TRUE, rho=0.5)
save(CNdiffSplOrtHPV, file="CNdiffSplOrtHPV.RData")
rm(CNdiffSplOrtHPV)
#####################################################################################################################################################################
#####################################################################################################################################################################
#####################################################################################################################################################################

form <- y ~ x + f(timefac, model="z", Z=ZSpline, initial=3, prior="loggamma", param=c(1,0.00001))-1
shrinksimul <- ShrinkHyperPar(form=form, dat=GEhpv3, dat1=CNhpv3R, timefac=timefac, groupfac=groupfac, ZSpline=ZSpline,
                              shrinkfixed="x", shrinkrandom="timefac", shrinksigma=TRUE, mixtrand=FALSE,
                              ncpus=numcpus2use, addpackage=c("splines"), orthogonal=FALSE, shrink=TRUE)

CNdiffSplHPVno <- FitIntAllShrink(form, dat=GEhpv3, dat1=CNhpv3R, timefac=timefac, groupfac=groupfac, ZSpline=ZSpline,
                             fams="gaussian", shrinksimul=shrinksimul, ncpus=numcpus2use, orthogonal=FALSE, shrink=FALSE, multivar=TRUE, rho=0.5)
save(CNdiffSplHPVno, file="CNdiffSplHPVno.RData")
rm(CNdiffSplHPVno)
form <- y ~ groupfacHPV + x + f(timefac, model="z", Z=ZSpline, initial=3, prior="loggamma", param=c(1,0.00001))-1
shrinksimul <- ShrinkHyperPar(form=form, dat=GEhpv3, dat1=CNhpv3R, timefac=timefac, groupfac=groupfac, ZSpline=ZSpline,
                              shrinkfixed="x", shrinkrandom="timefac", shrinksigma=TRUE, mixtrand=FALSE,
                              ncpus=numcpus2use, addpackage=c("splines"), orthogonal=FALSE, shrink=TRUE)

CNdiffSplHPV <- FitIntAllShrink(form, dat=GEhpv3, dat1=CNhpv3R, timefac=timefac, groupfac=groupfac, ZSpline=ZSpline,
                             fams="gaussian", shrinksimul=shrinksimul, ncpus=numcpus2use, orthogonal=FALSE, shrink=FALSE, multivar=TRUE, rho=0.5)
save(CNdiffSplHPV, file="CNdiffSplHPV.RData")
rm(CNdiffSplHPV)

#########################################################################################################################################################################################################
#          Testing
#########################################################################################################################################################################################################

################################################################################
#          Testing for Temporal Differential Expression - Same Spline - Model with copy number
################################################################################
annotation <- cbind(rownames(CNhpv3R),fData(GEdata)[,5])
Result <- TDGE(dat=GEhpv3, dat1=NULL, FitAlt=sameSpl[[1]], FitNull=CL[[1]], DsgGroup=DsgGroup, DsgSpl=ZSpline, annotation=annotation, multivar=FALSE, sortby=5)
head(Result)
p <- as.numeric(as.character(Result[,5]))
length(p[p<0.05])
################################################################################
#          Testing for DNA Copy Number Effect - Same Spline - Full Model
################################################################################
# Univariate
Result <- TDGEindCN(FitAlt=CNsameSpl[[1]], FitNull=diffSpl[[1]], dat=GEhpv3, annotation=annotation, multivar=FALSE)
head(Result)
p <- as.numeric(as.character(Result[,5]))
length(p[p<0.05])

# Multivariate
Result <- TDGEindCN(FitAlt=CNsameSplOrt[[1]], FitNull=sameSpl[[1]], dat=GEhpv3, annotation=annotation, multivar=TRUE)
head(Result)
p <- as.numeric(as.character(Result[,5]))
length(p[p<0.05])

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

#########################################################################################################################################################################################################
#          Calculate obtimal number of knots
#########################################################################################################################################################################################################
form <- y ~  groupfac + f(timefac, model="z", Z=ZSpline, initial=3, prior="loggamma", param=c(1,0.00001))-1
NumKnots(form=form,dat=GEcervix3,dat1=CNcervix3,numtp=8,numgroup=4,shrinksimul=shrinksimul,DiffSpl=FALSE)

#########################################################################################################################################################################################################
#          Function for ploting model fit
#########################################################################################################################################################################################################
# fit: Fit object of the model
# fit1: Fit object of the another model in the case that you wnat to compare fit of two models
# grpLabel: Labels required for lattice plot
# Around0: Scale data and fit around zero
# lattice: If TRUE make lattice plot

label <- c("CellLine1","CellLine1","CellLine1","CellLine1","CellLine1","CellLine1","CellLine1","CellLine1",
              "CellLine2","CellLine2","CellLine2","CellLine2","CellLine2","CellLine2","CellLine2","CellLine2",
              "CellLine3","CellLine3","CellLine3","CellLine3","CellLine3","CellLine3","CellLine3","CellLine3",
              "CellLine4","CellLine4","CellLine4","CellLine4","CellLine4","CellLine4","CellLine4","CellLine4")

Plot_inlafit(fit=sameSpl[[1]][[i]], fit1=group[[1]][[i]]$multiFit, numtp=numtp, numgroup=numgroup, grpLabel=label, Around0=FALSE, lattice=TRUE)


## 2. Calling functions ##

# Define the add function.
add <- function(a, b){
    return(a + b)
}

# Call the add function with the arguments 1 and 2.
print(add(1, 2))
d = add(5, 10)

## 3. Defining a function ##

# Enter your code here.
subtract <- function(a, b){
    return(a - b)
}
d = subtract(50,10)

## 4. Reading in the data ##

# Enter your code here.
ufos = read.csv('ufo_sightings.csv')

## 5. Exploring the data frame ##

# Print the first 5 rows in the data frame.
print(head(ufos, 5))
print(tail(ufos, 5))

## 6. UFO sighting years ##

# Enter your code here.
print(str(ufos))

## 7. Converting types ##

dateReported <- as.character(ufos$date.reported)
dateSighted <- as.character(ufos$date.sighted)

## 8. Substring function ##

# This extracts "2004" from our string.
date <- "20040415"
print(substr(date, 1, 4))

# This extracts the year from each string in the vector.
dates <- c("20040415", "20080515")
print(substr(dates, 1, 4))
years <- substr(dateSighted, 1, 4)

## 9. Making a table ##

# Create a small vector with a few years
selectedYears <- c("2004", "2002", "1992", "2005", "2006", "2005", "2004")

# Create and print a table
print(table(selectedYears))
print(table(years))

## 10. Working with dates ##

dateSighted <- as.character(ufos$date.sighted)
dateSighted <- as.Date(dateSighted, "%Y%m%d")
dateReported <- as.character(ufos$date.reported)
dateReported <- as.Date(dateReported, "%Y%m%d")

## 11. Subtracting vectors ##

# Enter your code here.
delay <- dateReported - dateSighted

## 12. Making a table of delays ##

# Enter your code here.
print(table(delay))

## 13. Cleaning up the data ##

# Enter your code here.
dates = data.frame(dateReported,dateSighted)

## 14. Booleans ##

a <- c(1,2,3)
b <- c(5,2,5)

# Find when each element in a is greater than the corresponding element in b.
print(a > b)
positiveDelays <- delay > 0

## 15. Filtering with booleans ##

filter <- c(FALSE, FALSE, TRUE, TRUE)
bestIceCreamFlavors <- data.frame(c("Peanut Butter Oreo", "Cookie Dough", "Mint Chocolate Chip", "Peanut Butter Cup"))
twoFlavors <- bestIceCreamFlavors[filter,]
print(twoFlavors)
positiveDates <- dates[positiveDelays,]

## 16. Null values ##

# Enter your code here.
cleanDates <- na.omit(positiveDates)

## 17. Remaking our table ##

# Enter your code here.
delay <- cleanDates$dateReported - cleanDates$dateSighted
print(table(delay))

R Programming Beginner/Working with data frames-127.r


library(ggplot2)
library(reshape2)
library(sandwich)
library(lmtest)
library(tseries)
library(dplyr)
library(urca)
library(forecast)
library(data.table)
library(stringr)

rm(list=ls())
gc()

source("startest.r")
source("lstar.r")
source("estar.r")

## load the data
load("forecast80.RData")
load("subset.RData")

c_num <- ncol(subset_dt)-1

c_names <- names(subset_dt)[1:c_num]

commodities <- c("Aluminum","Bananas","Cotton","Diammonium Phosphate","Fishmeal",
                 "Groundnut Oil","Groundnuts","Gold","Hides","Lamb",
                 "Lead","Soft Logs","Oranges","Olive Oil","Platinum",
                 "Plywood","Palm Oil","Rice","Rapeseed Oil","Rubber",
                 "Soybean Oil","Hard Sawnwood","Soft Sawnwood","Uran","Urea")

sub_dt$cmd <- commodities

## this is sort of arbitrary, but
# in general: agricultural(1)--forestry(2,3)--metals & minerals(4,5)
grp_order <- c(5,.9,1,4,2,
               2,2,5,1.9,1.8,
               5,3,.9,2,5,
               3,2,1,2,2.5,
               2,3,3,5,4)
sub_dt$grp <- grp_order
sub_dt <- sub_dt[order(grp,cmd)]

colnames(subset_dt) <- c(commodities,"Date")

subset_lg <- melt(subset_dt,id.vars = "Date", variable.name = "Commodity",value.name = "Price")

subset_lg$Commodity <- factor(subset_lg$Commodity,levels=sub_dt$cmd)

gg_panel <- ggplot(subset_lg,aes(x=Date,y=log(Price)))+
  geom_line(size=0.4,color="gray30")+
  facet_wrap(~Commodity,scales="free",ncol=5)+
  scale_y_continuous(labels = scales::number_format(accuracy=0.1))+
  labs(x="Year",y="Price")+
  theme_classic()+
  theme(axis.title = element_text(size=10),axis.text.x=element_text(size=6,angle=45,hjust=.8),axis.text.y=element_text(size=6),strip.text=element_text(size=6),strip.background=element_blank())

# ggsave("Paper/Prices.eps",gg_panel,width=6.5,height=6.5,units="in",device="eps")
# ggsave("Paper/Prices.png",gg_panel,width=6.5,height=6.5,units="in",device="png")
# ggsave("Presentation/Prices.png",gg_panel,width=6.5,height=4.5,units="in",device="png")

forecast_ar <- array_forecast[,,63,]

dimnames(forecast_ar) <- list(month.abb,c("realised","rw","iAR","iSTAR","dAR","dSTAR"),commodities)

forecast_dt <- as.data.table(forecast_ar)

colnames(forecast_dt) <- c("horizon","series","commodity","value")
forecast_dt <- forecast_dt[series!="rw"]

forecast_dt$commodity <- factor(forecast_dt$commodity,levels=sub_dt$cmd)
forecast_dt$horizon <- factor(forecast_dt$horizon,levels=month.abb)
forecast_dt$series <- factor(forecast_dt$series,levels=unique(forecast_dt$series)[c(5,4,3,2,1)])

forecast_dt$value <- as.numeric(forecast_dt$value)

gg_forecast <- ggplot(forecast_dt,aes(x=horizon,y=value,color=series,linetype=series,group=series))+
  geom_line(size=0.4)+
  facet_wrap(~commodity,scales="free",ncol=5)+
  scale_color_manual(values=c("darkgray","indianred","steelblue","goldenrod","seagreen"))+
  scale_x_discrete(breaks=month.abb[c(3,6,9,12)],labels=month.abb[c(3,6,9,12)])+
  scale_y_continuous(labels = scales::number_format(accuracy=0.01))+
  labs(x="Month",y="Price")+
  theme_classic()+
  theme(axis.title = element_text(size=10),axis.text.x=element_text(size=6),axis.text.y=element_text(size=6),strip.text=element_text(size=6),strip.background=element_blank(),legend.position = "top",legend.title=element_blank())

# ggsave("Paper/Forecasts2018.eps",gg_forecast,width=6.5,height=6.5,units="in",device="eps")
# ggsave("Paper/Forecasts2018.png",gg_forecast,width=6.5,height=6.5,units="in",device="png")
# ggsave("Presentation/Forecasts2018.png",gg_forecast,width=6.5,height=4.5,units="in",device="png")


TabModelData <- read.csv("~/GitHub/RAnalyses/TabModelData.csv")
View(TabModelData)
df <- TabModelData
TabModelData <- NULL
TabModelData <- NULL
df$DATE_VALUE <- NULL
df$RECORD <- NULL
df$LAST_NAME <- NULL
df$ADDRESS_LINE_1
df$ADDRESS_LINE_1 <- NULL
df$STATE_CODE <- NULL
df$ZIP <- NULL
df$MINSALEDATE <- NULL
df$LASTTABDATE <- NULL
summary(df)

df$REWARDS_CUSTOMER <- factor(df$REWARDS_CUSTOMER)

train.y <- df$PURCHASED_FIRST_15
collist <- c('MALES_IN_HOUSHOLD','REWARDS_CUSTOMER',
             'DAYS_AS_CUSTOMER','TOTAL_TRANSACTIONS','TOTAL_SPEND',
             'DAYS_SINCE_PURCHASE')
train.x <- df[, collist]

train.x$MALES_IN_HOUSHOLD <- scale(train.x$MALES_IN_HOUSHOLD)
train.x$FEMALES_IN_HOUSHOLD <-NULL
train.x$DAYS_AS_CUSTOMER <- scale(train.x$DAYS_AS_CUSTOMER)
train.x$TOTAL_TRANSACTIONS <- scale(train.x$TOTAL_TRANSACTIONS)
train.x$REW_TRANSACTIONS <- NULL
train.x$TOTAL_SPEND <- scale(train.x$TOTAL_SPEND)
train.x$DAYS_SINCE_PURCHASE <- scale(train.x$DAYS_SINCE_PURCHASE)

summary(train.x)

library(keras)

model <- keras_model_sequential()
model %>%
  layer_dense(units = 12, activation = 'relu', input_shape = c(6)) %>%
  layer_dense(units = 24, activation = 'relu') %>%
  layer_dropout(rate=0.8) %>%
  layer_dense(units = 36, activation = 'relu') %>%
  layer_dropout(rate=0.8) %>%
  layer_dense(units = 18, activation = 'relu') %>%
  layer_dropout(rate=0.8) %>%
  layer_dense(units = 6, activation = 'relu') %>%
  layer_dense(units = 2, activation = 'softmax')

summary(model)

model %>% compile(
  loss = 'binary_crossentropy',
  optimizer = 'adadelta',
  metrics = c('accuracy')
)

trainX<- as.matrix(train.x)
trainY <- to_categorical(as.matrix(train.y), num_classes = 2)

history <- model %>% fit(x = trainX, y = trainY,
                         epochs = 10, batch_size = 128,
                         validation_split = 0.4,
                         verbose = 1,
                         shuffle = T
)

plot(history)

# Plot the model loss
plot(history$metrics$loss, main="Model Loss", xlab = "epoch", ylab="loss", col="blue", type="l")
lines(history$metrics$val_loss, col="green")
legend("topright", c("train","test"), col=c("blue", "green"), lty=c(1,1))

# Plot the model accuracy
plot(history$metrics$acc, main="Model Accuracy", xlab = "epoch", ylab="accuracy", col="blue", type="l")
lines(history$metrics$val_acc, col="green")
legend("bottomright", c("train","test"), col=c("blue", "green"), lty=c(1,1))