#running R files: Rscript -e "source('E:/programs/R/first.r')"
#in the paranthese is the path to the file and must be run in cmd or powershell
#or simply go to the direction of the file and print: rscript first.r
#to switch to r command prompt, print rterm
myString <- "Hello, World!"
print ( myString)

# r does not support multiline comments but here's a trick
if(FALSE){
    "unlike c or java programming, in r variables are not determined by their datatype
    but instead, The variables are assigned with R-Objects and the data type of the R-object
    becomes the data type of the variable. There are many types of R-objects.
    The frequently used ones are:"
    '==> Vectors
     ==> Lists
     ==> Matrices
     ==> Arrays
     ==> Factors
     ==> Data Frames'

     "data types of these objects can be, Logical,Numeric,Integer,Complex,Character,Raw"
}
v1 <- TRUE  #FALSE and TRUE should all be in capitals to work, not True or false
v2 <- 23.5
v3 <- 2L
v4 <- 2+5i
v5 <- "true"
v6 <- charToRaw("Hello")
print(paste0(class(v1)," ",class(v2)," ",class(v3)," ",class(v4)," ",class(v5)," ",class(v6)))
cat("The number is :",v2) #it does the job of paste and also prints
print("  ")

#when creating vectors with more than one element, we use c() to combine elements into a vector
# Create a vector.
apple <- c('red','green',"yellow")
print(apple)

# Get the class of the vector.
print(class(apple))

#A list is an R-object which can contain many different types of elements inside it
#like vectors, functions and even another list inside it.
# Create a list.
list1 <- list(c(2,5,3),21.3,sin)

# Print the list.
print(list1)

# Create a matrix.(It can be created using a vector input to the matrix function.)
M = matrix( c('a','a','b','c','b','a'), nrow = 2, ncol = 3, byrow = TRUE)
print(M)

#Matrices are only in two dimensions while arrays can be in many dimensions
#The array function takes a dim attribute which creates the required number of dimension.
# Create an array.(an array with 2 elements that each element is a 3*3 matrix)
a <- array(c('green','yellow'),dim = c(3,3,2))
print(a)

# a factor stores the vector with the distinct values that it contains as labels.
#the labels are characters, irrespective of what they are in the vector(numeric,logical,etc)
#Factors are useful in statistical modelling.
# Create a vector.
apple_colors <- c('green','green','yellow','red','red','red','green')

# Create a factor object.
factor_apple <- factor(apple_colors)

# Print the factor.
print(factor_apple)
print(nlevels(factor_apple)) #nlevels function gives the count of levels.

#Data frames are lists of vectors of equal length
#Unlike a matrix in data frame each column can contain different modes of data.
#Data Frames are created using the data.frame() function.
# Create the data frame.
BMI <- 	data.frame(
   gender = c("Male", "Male","Female"),
   height = c(152, 171.5, 165),
   weight = c(81,93, 78),
   Age = c(42,38,26)
)
print(BMI)

#variable assignment
# Assignment using equal operator.(dot is accepted in naming variables)
var.1 = c(0,1,2,3)

# Assignment using leftward operator.
var.2 <- c("learn","R")

# Assignment using rightward operator.
c(TRUE,1) -> var.3  #logical class is coerced to numeric class making TRUE as 1
c(TRUE,1,"hello") ->> var.4
print(var.1)
cat ("var.1 is ", var.1 ,"\n")
cat ("var.2 is ", var.2 ,"\n")
cat ("var.3 is ", var.3 ,"\n")
cat ("class of var.3 is ", class(var.3) ,"class of var.4 is",typeof(var.4),"\n")

#To know all the variables currently available in the workspace we use the ls() function.
print(ls()) #print(ls(all.name = TRUE)) is to show variables starting with dot with others

rm(var.3) #deleting variable var.3
# print(var.3) #deleting all the variables by: rm(list=ls())

v <- c( 2,5.5,6)
t <- c(8, 3, 4)
print(v+t) #Arithmetic operations on vectors
print(v-t)
print(v*t)
print(v/t)
print(v%%t) #remainder of the first vector with the second
print(v%/%t) #quotient
print(v^t) #exponentiation

print(v>=t) #Relational operations
print(v!=t)

#Assignment can be done by = , -> , ->>

logic1 = c(TRUE,FALSE,TRUE) #Logical operations
logic2 = c(FALSE,TRUE,TRUE)
print(logic1 & logic2) #elementwise logical and
print(logic1 | logic2) #elementwise logical or
print(!logic2) #logical not operator
print(logic1 && logic2) #logical and operator (only checks the first element)
print(logic1 || logic2) #logical or operator (only checks the first element)

series1 <- 2:6 # : operator is for holding the sequence of numbers
new1 <- 12
series2 <- 1:10 #%n% is for checking if an element belongs to a vector.
print(new1 %in% series2)

M1 = matrix(c(1,0,0,1), nrow=2, ncol=2, byrow=TRUE) #the identity matrix
M2 = matrix(c(2,3,4,5), nrow=2, ncol=2, byrow=TRUE)
t = M1 %*% M2 # %*% is used for matrix multiplication
print(t)

M = matrix( c(2,6,5,1,10,4), nrow = 2,ncol = 3,byrow = TRUE)
t = M %*% t(M) # t(M) is the transpose of the matrix M
print(t)


 ZHEGST Example Program Results

 Eigenvalues
    -5.9990 -2.9936  0.5047  3.9990


                         CHAPTER  3

                    Arithmetic Functions

     This chapter describes FRANZ LISP's functions for doing
arithmetic.  Often the same function is known by many names.
For example, _a_d_d is also _p_l_u_s, and _s_u_m.  This is  caused  by
our  desire  to  be  compatible with other Lisps.  The FRANZ
LISP user should avoid using functions with names such as  +
and * unless their arguments are fixnums.  The Lisp compiler
takes advantage of these implicit declarations.

     An attempt to divide or to generate  a  floating  point
result  outside  of the range of floating point numbers will
cause a floating exception signal from  the  UNIX  operating
system.   The  user  can catch and process this interrupt if
desired (see the description of the _s_i_g_n_a_l function).

   3.1.  Simple Arithmetic Functions

(add ['n_arg1 ...])
(plus ['n_arg1 ...])
(sum ['n_arg1 ...])
(+ ['x_arg1 ...])

     RETURNS: the sum of the arguments. If no arguments  are
              given, 0 is returned.

     NOTE: if the size of the partial sum exceeds the  limit
           of a fixnum, the partial sum will be converted to
           a bignum.  If any of the arguments  are  flonums,
           the  partial  sum  will  be converted to a flonum
           when that argument is processed  and  the  result
           will thus be a flonum.  Currently, if in the pro-
           cess of doing the addition a bignum must be  con-
           verted  into  a  flonum  an  error  message  will
           result.

9

9Arithmetic Functions                                     3-1

Arithmetic Functions                                     3-2

(add1 'n_arg)
(1+ 'x_arg)

     RETURNS: its argument plus 1.

(diff ['n_arg1 ... ])
(difference ['n_arg1 ... ])
(- ['x_arg1 ... ])

     RETURNS: the result of subtracting from n_arg1 all sub-
              sequent  arguments. If no arguments are given,
              0 is returned.

     NOTE: See the description of add for  details  on  data
           type conversions and restrictions.

(sub1 'n_arg)
(1- 'x_arg)

     RETURNS: its argument minus 1.

(minus 'n_arg)

     RETURNS: zero minus n_arg.

(product ['n_arg1 ... ])
(times ['n_arg1 ... ])
(* ['x_arg1 ... ])

     RETURNS: the product  of  all  of  its  arguments.   It
              returns 1 if there are no arguments.

     NOTE: See the  description  of  the  function  _a_d_d  for
           details  and  restrictions  to the automatic data
           type coercion.

(quotient ['n_arg1 ...])
(/ ['x_arg1 ...])

     RETURNS: the result of dividing the first  argument  by
              succeeding ones.

     NOTE: If there are no arguments, 1  is  returned.   See
           the  description  of the function _a_d_d for details
           and restrictions of data type coercion.  A divide
           by zero will cause a floating exception interrupt
           -- see the description of the _s_i_g_n_a_l function.

9

9                                   Printed: January 31, 1984

Arithmetic Functions                                     3-3

(*quo 'i_x 'i_y)

     RETURNS: the integer part of i_x / i_y.

(Divide 'i_dividend 'i_divisor)

     RETURNS: a list whose car is  the  quotient  and  whose
              cadr  is  the  remainder  of  the  division of
              i_dividend by i_divisor.

     NOTE: this is restricted to integer division.

(Emuldiv 'x_fact1 'x_fact2 'x_addn 'x_divisor)

     RETURNS: a list of the quotient and remainder  of  this
              operation:
              ((x_fact1 * x_fact2) + (sign extended) x_addn) / x_divisor.

     NOTE: this  is  useful for creating a bignum arithmetic
           package in Lisp.

   3.2.  predicates

(numberp 'g_arg)

(numbp 'g_arg)

     RETURNS: t iff g_arg is a  number  (fixnum,  flonum  or
              bignum).

(fixp 'g_arg)

     RETURNS: t iff g_arg is a fixnum or bignum.

(floatp 'g_arg)

     RETURNS: t iff g_arg is a flonum.

(evenp 'x_arg)

     RETURNS: t iff x_arg is even.

9

9                                   Printed: January 31, 1984

Arithmetic Functions                                     3-4

(oddp 'x_arg)

     RETURNS: t iff x_arg is odd.

(zerop 'g_arg)

     RETURNS: t iff g_arg is a number equal to 0.

(onep 'g_arg)

     RETURNS: t iff g_arg is a number equal to 1.

(plusp 'n_arg)

     RETURNS: t iff n_arg is greater than zero.

(minusp 'g_arg)

     RETURNS: t iff g_arg is a negative number.

(greaterp ['n_arg1 ...])
(> 'fx_arg1 'fx_arg2)
(>& 'x_arg1 'x_arg2)

     RETURNS: t iff the arguments are in a strictly decreas-
              ing order.

     NOTE: In functions _g_r_e_a_t_e_r_p and > the function  _d_i_f_f_e_r_-
           _e_n_c_e  is  used to compare adjacent values. If any
           of the arguments are non-numbers, the error  mes-
           sage will come from the _d_i_f_f_e_r_e_n_c_e function.  The
           arguments to > must  be fixnums or both  flonums.
           The arguments to >& must both be fixnums.

(lessp ['n_arg1 ...])
(< 'fx_arg1 'fx_arg2)
(<& 'x_arg1 'x_arg2)

     RETURNS: t iff the arguments are in a strictly increas-
              ing order.

     NOTE: In functions _l_e_s_s_p and < the function  _d_i_f_f_e_r_e_n_c_e
           is used to compare adjacent values. If any of the
           arguments are non numbers, the error message will
           come from the _d_i_f_f_e_r_e_n_c_e function.  The arguments
           to < may be either fixnums or flonums but must be
           the  same type.  The arguments to <& must be fix-
           nums.

9

9                                   Printed: January 31, 1984

Arithmetic Functions                                     3-5

(= 'fx_arg1 'fx_arg2)

(=& 'x_arg1 'x_arg2)

     RETURNS: t iff the arguments have the same value.   The
              arguments to = must be the either both fixnums
              or both flonums.  The arguments to =& must  be
              fixnums.

   3.3.  Trignometric Functions

           Some of these funtcions are taken from  the  host
      math  library,  and  we take no further responsibility
      for their accuracy.

(cos 'fx_angle)

     RETURNS: the (flonum)  cosine  of  fx_angle  (which  is
              assumed to be in radians).

(sin 'fx_angle)

     RETURNS: the sine of fx_angle (which is assumed  to  be
              in radians).

(acos 'fx_arg)

     RETURNS: the (flonum) arc cosine of fx_arg in the range
              0 to J.

(asin 'fx_arg)

     RETURNS: the (flonum) arc sine of fx_arg in  the  range
              -J/2 to J/2.

(atan 'fx_arg1 'fx_arg2)

     RETURNS: the (flonum) arc tangent of fx_arg1/fx_arg2 in
              the range -J to J.

   3.4.  Bignum/Fixnum Manipulation

9

9                                   Printed: January 31, 1984

Arithmetic Functions                                     3-6

(haipart bx_number x_bits)

     RETURNS: a fixnum (or bignum) which contains the x_bits
              high  bits  of  (_a_b_s _b_x__n_u_m_b_e_r)  if  x_bits is
              positive,    otherwise    it    returns    the
              (_a_b_s _x__b_i_t_s) low bits of (_a_b_s _b_x__n_u_m_b_e_r).

(haulong bx_number)

     RETURNS: the number of significant bits in bx_number.

     NOTE: the result is equal to the least integer  greater
           to or equal to the base two logarithm of one plus
           the absolute value of bx_number.

(bignum-leftshift bx_arg x_amount)

     RETURNS: bx_arg shifted left by x_amount.  If  x_amount
              is  negative,  bx_arg will be shifted right by
              the magnitude of x_amount.

     NOTE: If bx_arg is shifted right, it will be rounded to
           the nearest even number.

(sticky-bignum-leftshift 'bx_arg 'x_amount)

     RETURNS: bx_arg shifted left by x_amount.  If  x_amount
              is  negative,  bx_arg will be shifted right by
              the magnitude of x_amount and rounded.

     NOTE: sticky rounding is done this way: after shifting,
           the low order bit is changed to 1 if any 1's were
           shifted off to the right.

   3.5.  Bit Manipulation

(boole 'x_key 'x_v1 'x_v2 ...)

     RETURNS: the result of the bitwise boolean operation as
              described in the following table.

     NOTE: If there are more than 3 arguments, then  evalua-
           tion  proceeds  left  to  right with each partial
           result becoming the new value of x_v1.  That is,
                (_b_o_o_l_e '_k_e_y '_v_1 '_v_2 '_v_3) =_ (_b_o_o_l_e '_k_e_y (_b_o_o_l_e '_k_e_y '_v_1 '_v_2) '_v_3).
           In the following table, * represents bitwise and,
           + represents bitwise or, O+ represents bitwise xor
           and  _  represents  bitwise  negation  and is the
           highest precedence operator.

Arithmetic Functions                                     3-7

8____________________________________________________________________________________________
                                     (boole 'key 'x 'y)

8________________________________________________________________________________________________________________________________________________________________________________________
  key         0          1          2         3         4          5          6         7
 result       0        x * y     _ x * y      y      x * _ y       x        x O+ y     x + y

 common
 names                  and                          bitclear                xor       or

8____________________________________________________________________________________________

  key         8          9         10        11         12        13         14        15
 result   _ (x + y)   _(x O+ y)     _ x     _ x + y     _ y      x + _ y   _ x + _ y    -1
 common
 names       nor       equiv               implies                          nand
8____________________________________________________________________________________________
7|8|7|7|7|7|7|7|7|7|7|7|7|7|7|

9                                                                                |8|7|7|7|7|7|7|7|7|7|7|7|7|7|

9
(lsh 'x_val 'x_amt)

     RETURNS: x_val shifted left by x_amt if x_amt is  posi-
              tive.   If x_amt is negative, then _l_s_h returns
              x_val shifted right by the magnitude if x_amt.

     NOTE: This always  returns  a  fixnum  even  for  those
           numbers  whose  magnitude  is  so large that they
           would normally be represented as a  bignum,  i.e.
           shifter  bits  are  lost.   For  more general bit
           shifters,  see   _b_i_g_n_u_m-_l_e_f_t_s_h_i_f_t   and   _s_t_i_c_k_y-
           _b_i_g_n_u_m-_l_e_f_t_s_h_i_f_t.

(rot 'x_val 'x_amt)

     RETURNS: x_val rotated left by x_amt if x_amt is  posi-
              tive.  If  x_amt  is  negative,  then x_val is
              rotated right by the magnitude of x_amt.

   3.6.  Other Functions

           As noted above, some of the  following  functions
      are  inherited  from  the  host math library, with all
      their virtues and vices.

9

9                                   Printed: January 31, 1984

Arithmetic Functions                                     3-8

(abs 'n_arg)
(absval 'n_arg)

     RETURNS: the absolute value of n_arg.

(exp 'fx_arg)

     RETURNS: _e raised to the fx_arg power (flonum) .

(expt 'n_base 'n_power)

     RETURNS: n_base raised to the n_power power.

     NOTE: if either of the arguments are flonums, the  cal-
           culation will be done using _l_o_g and _e_x_p.

(fact 'x_arg)

     RETURNS: x_arg factorial. (fixnum or bignum)

(fix 'n_arg)

     RETURNS: a fixnum as close as we can get to n_arg.

     NOTE: _f_i_x will round down.  Currently, if  n_arg  is  a
           flonum  larger  than  the  size of a fixnum, this
           will fail.

(float 'n_arg)

     RETURNS: a flonum as close as we can get to n_arg.

     NOTE: if n_arg is a bignum larger than the maximum size
           of  a  flonum,  then  a  floating  exception will
           occur.

(log 'fx_arg)

     RETURNS: the natural logarithm of fx_arg.

(max 'n_arg1 ... )

     RETURNS: the maximum value in the list of arguments.

9

9                                   Printed: January 31, 1984

Arithmetic Functions                                     3-9

(min 'n_arg1 ... )

     RETURNS: the minimum value in the list of arguments.

(mod 'i_dividend 'i_divisor)
(remainder 'i_dividend 'i_divisor)

     RETURNS: the remainder when i_dividend  is  divided  by
              i_divisor.

     NOTE: The sign of the result will have the same sign as
           i_dividend.

(*mod 'x_dividend 'x_divisor)

     RETURNS: the  balanced  representation  of   x_dividend
              modulo x_divisor.

     NOTE: the  range  of  the  balanced  representation  is
           abs(x_divisor)/2    to    (abs(x_divisor)/2)    -
           x_divisor + 1.

(random ['x_limit])

     RETURNS: a fixnum between 0 and x_limit - 1 if  x_limit
              is  given.   If x_limit is not given, any fix-
              num, positive or negative, might be returned.

(sqrt 'fx_arg)

     RETURNS: the square root of fx_arg.

9

9                                   Printed: January 31, 1984


pdf_file<-"pdf/tablecharts_treemap_2a_inc.pdf"
cairo_pdf(bg="grey98", pdf_file,width=11.69,height=7.5)

par(omi=c(0.65,0.25,1.25,0.75),mai=c(0.3,2,0.35,0),family="Lato Light",las=1)
library(treemap)
library(RColorBrewer)

# Read data and prepare chart

load("myData/hnp.RData")
myData<-subset(daten,daten$gni>0)
attach(myData)
popgni<-pop*gni
myData$popgni<-popgni
myContinents<-aggregate(cbind(pop,popgni) ~ kontinent,data=myData,sum)
kgni<-myContinents$popgni/myContinents$pop
myContinents$kgni<-kgni
kkgni<-cut(kgni,c(0,5000,10000,100000))
levels(kkgni)<-c("low","middle","high")
myContinents$kkgni<-kkgni
myContinents$nkkgni<-as.numeric(kkgni)

# Create chart and other elements

plot(1:1,type="n",axes=F)
treemap(myContinents,title="",index="kontinent", vSize="pop",vColor="kgni",type="value",palette="YlOrBr",aspRatio=2.5,position.legend="none",inflate.labels=T)
legend(0.35,0.6,levels(kkgni)[1:3],cex=1.65,ncol=6,border=F,bty="n",fill= brewer.pal(5,"YlOrBr")[3:5],text.col="black",xpd=NA)

# Titling

mtext("Population and Gross National Income",3,line=2,adj=0,cex=2.4,outer=T,family="Lato Black")
mtext("Size: population - Colour: GNI per capita. Atlas method (current US $), 2010",3,line=0,adj=0,cex=1.75,outer=T,font=3)
mtext("",1,line=1,adj=1.0,cex=1.25,outer=T,font=3)
dev.off()


rm(list=ls())
library(dplyr)
library(tidyr)
library(ggplot2)
library(ggpubr)

# set dataset

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

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

# Read in data

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

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

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

# Bayes factors

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

mL <- mLBF

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

## Make column of support interpretation for each hypothesis

mL <- mutate(mL, TvS_support = case_when(TvS > 10 ~ "Very Strong for Tox",
                                         TvS <= 10 &  TvS >= 6 ~ "Strong for Tox",
                                         TvS > -6 & TvS < 6 ~ "Ambiguous",
                                         TvS >= -10 & TvS <= 6 ~ "Strong for Sclero",
                                         TvS < -10 ~ "Very Strong for Sclero"))

TvS_BFsupport <- mL %>% group_by(TvS_support) %>% dplyr::summarise(counts=n())
TvS_BFsupport$TvS_support <- factor(TvS_BFsupport$TvS_support, levels=c("Very Strong for Tox","Strong for Tox","Ambiguous","Strong for Sclero","Very Strong for Sclero"))

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

mLBF <- mL

rm(mL)

# Different in gene log likelihood

# dGLS = LH1 - LH2

mL <- mLGL

## Calculate dGLS and put in new columns
mL$TvS <- (mL$ToxPoly-mL$Sclero)
mL$AIvSA <- (mL$ToxAngIg-mL$ToxSnAng)
mL$AIvSI <- (mL$ToxAngIg-mL$ToxSnIg)
mL$SAvAI <- (mL$ToxSnAng-mL$ToxAngIg)
mL$SAvSI <- (mL$ToxSnAng-mL$ToxSnIg)
mL$SIvAI <- (mL$ToxSnIg-mL$ToxAngIg)
mL$SIvSA <- (mL$ToxSnIg-mL$ToxSnAng)

## Make column of support interpretation for each hypothesis

mL <- mutate(mL, TvS_support = case_when(TvS > 0.5 ~ "Very Strong for Tox",
                                         TvS <= 0.5 &  TvS >= 0.1 ~ "Strong for Tox",
                                         TvS > -0.1 & TvS < 0.1 ~ "Ambiguous",
                                         TvS >= -0.5 & TvS <= 0.1 ~ "Strong for Sclero",
                                         TvS < -0.5 ~ "Very Strong for Sclero"))

TvS_GLsupport <- mL %>% group_by(TvS_support) %>% dplyr::summarise(counts=n())
TvS_GLsupport$TvS_support <- factor(TvS_GLsupport$TvS_support, levels=c("Very Strong for Tox","Strong for Tox","Ambiguous","Strong for Sclero","Very Strong for Sclero"))

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

mLGL <- mL

rm(mL)

# If you want to save..

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


not <- function(x) { 1-x }
library(MASS)

a <- fractions(0.91)
b <- fractions(0.92)
c <- fractions(0.53)
ac <- not(a)
bc <- not(b)
cc <- not(c)
adenom <- a*bc*cc
bdenom <- ac*b*cc
cdenom <- ac*bc*c
h <- adenom + bdenom + cdenom
afinal <- adenom/h
bfinal <- bdenom/h
cfinal <- cdenom/h

print(afinal)
print(bfinal)
print(cfinal)


#Load Library and Data Set
setwd("F:/PRANAV\Project/Car Rental Prediction")
getwd()
data = read.csv("train_cab.csv", header = TRUE)
data1 = read.csv("test.csv", header = TRUE)
library(dplyr)
library(randomForest)
library(caret)
library(e1071)
head(data)
str(data)
summary(data)
data = select (data,c(passenger_count,fare_amount,pickup_longitude,pickup_latitude,dropoff_longitude,dropoff_latitude))

data$fare_amount = as.numeric(data$fare_amount)

#Missing Value Analysis
unique(data$passenger_count)
unique(data$fare_amount)
unique(data$pickup_longitude)
unique(data$pickup_latitude)
unique(data$dropoff_longitude)
unique(data$dropoff_longitude)
unique(data$pickup_datetime)

data <- data[complete.cases(data$fare_amount), ]
data <- data[complete.cases(data$passenger_count), ]
data <- data[complete.cases(data$pickup_longitude), ]
data <- data[complete.cases(data$pickup_latitude), ]
data <- data[complete.cases(data$dropoff_longitude), ]
data <- data[complete.cases(data$pickup_datetime), ]

#Split data into test and train
set.seed(500)
train <- sample(nrow(data), 0.7*nrow(data), replace = FALSE)
TrainSet <- data[train,]
ValidSet <- data[-train,]
summary(TrainSet)
summary(ValidSet)

#Applying Model to Train data
model <- randomForest(fare_amount ~ ., data = TrainSet, importance = TRUE)
model
plot(model)
model2 <- randomForest(fare_amount ~ ., data = TrainSet, ntree = 100, mtry = 4, importance = TRUE)
model2
plot(model2)
#--------------------

#Predicting Values
Model_lm1=lm(fare_amount~.,data=data)
summary(Model_lm1)
View(data)

#Applying Model on Test Data
prediction = predict (Model_lm1, data1)
View(data1)
output = cbind(data1, prediction)
View(output)


add <- function(x, y) {
return(x + y)
}
subtract <- function(x, y) {
return(x - y)
}
multiply <- function(x, y) {
return(x * y)
}
divide <- function(x, y) {
return(x / y)
}
print("Select operation.")
print("1. Add")
print("2. Subtract")
print("3. Multiply")
print("4. Divide")
choice = as.integer(readline(prompt="Enter choice[1/2/3/4]: "))
num1 = as.integer(readline(prompt="Enter first number: "))
num2 = as.integer(readline(prompt="Enter second number: "))
operator <- switch(choice,"+","-","*","/")
result <- switch(choice, add(num1, num2), subtract(num1, num2), multiply(num1, num2), divide(num1, num2))
print(paste(num1, operator, num2, "=", result))


years <- 2008:2121
xmas <- as.POSIXlt(paste0(years, '/12/25'))
years[xmas$wday==0]
# 2011 2016 2022 2033 2039 2044 2050 2061 2067 2072 2078 2089 2095 2101 2107 2112 2118

# Also:
xmas=seq(as.Date("2008/12/25"), as.Date("2121/12/25"), by="year")
as.numeric(format(xmas[weekdays(xmas)== 'Sunday'], "%Y"))

# Still another solution, using ISOdate and weekdays
with(list(years=2008:2121), years[weekdays(ISOdate(years, 12, 25)) == "Sunday"])

# Or with "subset"
subset(data.frame(years=2008:2121), weekdays(ISOdate(years, 12, 25)) == "Sunday")$years

# Simply replace "Sunday" with whatever it's named in your country,
# or set locale first, with
Sys.setlocale(cat="LC_ALL", "en")

# Under MS Windows, write instead
Sys.setlocale("LC_ALL", "English")


### Coerce multiple columns to factors

library(magrittr)
library(dplyr)

data <- data.frame(matrix(sample(1:40), 4, 10,
                          dimnames = list(1:4, LETTERS[1:10])))

factor_cols <- c("A", "C", "E", "G")

data %>% mutate_at(factor_cols, factor)
str(data)

### Calculate and show missing data percent per column

data %>%
    summarize_all(list(missing_percent = ~sum(is.na(.)) / length(.))) %>%
    ### if the data frame is too wide, then use gather to transform
    gather(col, value)

### Deal with NA

df <- data_frame(col1 = c(1, 2, 3, 0),
                 col2 = c(0, 2, 3, 4),
                 col3 = c(1, 0, 3, 0),
                 col4 = c('a', 'b', 'c', 'd'))

#change 0 in a given column to NA
df$col3 <- na_if(df$col3, 0)
#or
df$col3[df$col3 == 0] <- NA

#change a give number to NA for all observations in the data frame
df[df == 1] <- NA
#replace NAs in a column with mean of all observations in the column
df$col3[is.na(df$col3)] <- mean(df$col3, na.rm = TRUE)

### Get the column number given the column name
which(colnames(data) == "C")

### Get col names excluding some cols
cov_names <- subset(colnames(data), !(colnames(data) %in% c("C", "D")))

### Get P-value from glm summary
coef(summary(glm_model))[,4]


### In this script we simply fit the cure rate model to the E1684 study data to look at parameter estimates
### We'll fit the model and compare estimates with Chen, Ibrahim and Sinha (1999) [CIS99]
historical.data <- subset(read.csv("../data/e1684_and_e1690_data.csv", sep = "\t"),
                          study  == "1684" & survtime > 0)
summary(historical.data)

stand_age <- (historical.data$age -mean(historical.data$age))/sd(historical.data$age)
N_0 <- length(stand_age)
X_0 <- cbind(rep(1, N_0), # x0 - dummy for intercept
             stand_age, # x1 - (standardised) age
             historical.data$sex, # x2 - gender (sex)
             historical.data$perform # x3 performance status
             )
summary(X_0)
Y_0_cens <- historical.data$survtime
Delta_0 <- historical.data$scens
## Hyperparameters
mu0 <- 0
s0 <- 10

d0 <- 1
tau0 <- 1

########################3
library(rstan)
rstan_options(auto_write = TRUE)
options(mc.cores = 4)

#### Sampling
simple.model.cov <- stan_model("stan/cure_rate.stan")

E1684.data <- list(
  n = N_0,
  p = ncol(X_0),
  y = Y_0_cens,
  X = X_0,
  delta = Delta_0,
  mu_0 = mu0,
  sigma_0 = s0,
  delta_0 = d0,
  tau_0 = tau0,
  sigma_beta = 10
)

optimizing(simple.model.cov, data = E1684.data, verbose = TRUE)

mcmc <- sampling(simple.model.cov, data = E1684.data,
                 control = list(adapt_delta = 0.99, max_treedepth = 15, metric = "dense_e"))
mcmc

pairs(mcmc, pars = c("lambda", "alpha", "beta"))

# pars <- extract(mcmc, pars = c("lambda", "alpha", "beta"))
# M <- nrow(pars$beta)
#
# tcens <- 11
# source("cure_rate_aux.r")
# y_rep <- matrix(NA, ncol = E1684.data$n, nrow = M)
# for(i in 1:M){
#   y_rep[i, ] <- generate_n_data_points(n = E1684.data$n,
#                                        beta = pars$beta[i, ],
#                                        alpha = pars$alpha[i],
#                                        lambda= pars$lambda[i],
#                                        X = E1684.data$X,
#                                        tcs = tcens)$y_censored
# }
#
# library(bayesplot)
#
# plot0 <- ppc_ecdf_overlay(E1684.data$y, y_rep[1:min(100, round(M * .2)), ], discrete = TRUE) +
#   # ggtitle("")  +
#   NULL
# plot0
#
# plot1 <- ppc_stat(E1684.data$y, y_rep[1:M, ], stat = "mean", binwidth = 0.005) +
#   # ggtitle("")  +
#   NULL
# plot1
#
# plot2 <- ppc_stat(E1684.data$y, y_rep[1:M, ], stat = "sd", binwidth = 0.005) +
#   # ggtitle("")  +
#   NULL
# plot2
#
# q90 <- function(x) quantile(x, probs = .90)
# plot3 <- ppc_stat(E1684.data$y, y_rep[1:M, ], stat = "q90", binwidth = 0.005) +
#   # ggtitle("")  +
#   NULL
# plot3


library(dplyr)
library(ggplot2)
library(mapproj)

create_map <- function() {
  df_facility <-
    read.csv("data/Mental Health Facilities.csv", stringsAsFactors = FALSE)
  df_countries <-
    read.csv("data/suicide-rates-overview-1985-to-2016.csv", stringsAsFactors = FALSE)

  matches <- df_facility %>%
    select(Country, Year)

  df_countries_filtered <- df_countries %>%
    filter(year %in% matches$Year) %>%
    filter(country %in% matches$Country) %>%
    group_by(country) %>%
    filter(year == max(year)) %>%
    summarise(
      suicides_number = sum(suicides_no),
      gpd_per_capita = mean(gdp_per_capita....),
      suicides_100kpop = sum(suicides.100k.pop)
    )

  df_facility_filtered <- df_facility %>%
    filter(Country %in% df_countries_filtered$country) %>%
    group_by(Country) %>%
    summarise(
      total_avalibility_per100k = sum(Mental.hospitals..per.100.000.population.,
                                      Mental.health.units.in.general.hospitals..per.100.000.population.,
                                      Mental.health.outpatient.facilities..per.100.000.population.,
                                      Mental.health.day.treatment.facilities..per.100.000.population.,
                                      Community.residential.facilities..per.100.000.population.,
                                      na.rm = TRUE
      )
    )

  df_plotting <- df_countries_filtered %>%
    mutate(
      total_avalibility = df_facility_filtered$total_avalibility_per100k,
      ratio = suicides_100kpop/total_avalibility
    )

  world_shape <- map_data("world") %>%
    rename(country = region) %>%
    left_join(df_plotting, by = "country")

  blank_theme <- theme_bw() +
    theme(
      axis.line = element_blank(), # remove axis lines
      axis.text = element_blank(), # remove axis labels
      axis.ticks = element_blank(), # remove axis ticks
      axis.title = element_blank(), # remove axis titles
      plot.background = element_blank(), # remove gray background
      panel.grid.major = element_blank(), # remove major grid lines
      panel.grid.minor = element_blank(), # remove minor grid lines
      panel.border = element_blank() # remove border around plot
    )

  facility_map <- ggplot(world_shape) +
    geom_polygon(
      mapping = aes(x = long, y = lat, group = group, fill = ratio),
      color = "white",
      size = .1
    ) +
    coord_map(xlim = c(-180, 180)) +
    scale_fill_continuous(low = "#ffe6e6", high = "#800000") +
    labs(fill = "ratio") +
    blank_theme

  return(facility_map)
}


# Day 21: Dirac Dice

get_day21_input_path <- function() {
    paste(getwd(), "/2021/Day 21/Day21_input.txt", sep = "")
}

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

    p1_start <- as.numeric(unlist(strsplit(readings[1], ": "))[2])
    p2_start <- as.numeric(unlist(strsplit(readings[2], ": "))[2])

    p1_cur_space <- p1_start
    p2_cur_space <- p2_start

    num_rolls <- 0
    p1_score <- 0
    p2_score <- 0

    turn_num <- 1
    game_won <- FALSE

    while (!game_won) {
        sum_of_rolls <- 0
        for (i in 1:3) {
            sum_of_rolls <- sum_of_rolls + roll_det_100_die(num_rolls)
            num_rolls <- num_rolls + 1
        }
        if (turn_num %% 2 == 0) {
            p2_cur_space <- board_10_move_pawn(p2_cur_space, sum_of_rolls)
            p2_score <- p2_score + p2_cur_space

            if (p2_score >= 1000) {
                game_won <- TRUE
            }
        } else {
            p1_cur_space <- board_10_move_pawn(p1_cur_space, sum_of_rolls)
            p1_score <- p1_score + p1_cur_space

            if (p1_score >= 1000) {
                game_won <- TRUE
            }
        }
        turn_num <- turn_num + 1
    }

    cat("P1 Score: ", p1_score, "\n")
    cat("P2 Score: ", p2_score, "\n")
    cat("Roll Count: ", num_rolls, "\n")
    print(min(c(p1_score, p2_score)) * num_rolls)
}

part2 <- function() {
    print("TODO")
}

roll_det_100_die <- function(times_rolled) {
    if (times_rolled %% 100 == 0) {
        1
    } else {
        times_rolled + 1
    }
}

board_10_move_pawn <- function(cur_pos, num_spaces) {
    spaces_to_move <- num_spaces %% 10

    if (cur_pos + spaces_to_move <= 10) {
        cur_pos + spaces_to_move
    } else {
        (cur_pos + spaces_to_move) %% 10
    }
}

part1()
part2()


rm(list=ls())
if(Sys.getenv("USER")=="ebjan"){
  setwd("~/trw")
}else{
  setwd("~/Dropbox/trw")
}
library(fastICA)
library(mclust)
#m=3
m1=12
m2=12
source("startup.r")
source("trw_fit.r")
setwd("~")
source("~/Forest Density/treeLoader.R");
loadTree()
####################
set.seed(3498)
####################
len=100
ntest=300

limit=400
out_len=5

dat<-matrix( scan(file="~/trw/MEG_art",what=double()) , ncol=122, byrow=F)[1:(len+ntest),]
#save(file="meg.rdata",list=c("dat"))
#source("meg.rdata")
dat<-scale(dat,center=TRUE,scale=TRUE)
dat[abs(dat)>6.5]=6.5
#dat[which(abs(dat)>6)]<- sign(dat[which(abs(dat)>6)])*6
#data2<-fastICA(data2[1:1000,],n.comp=122)$S
dat<- apply(dat,2,function(x)(x-min(x)+.01)/(max(x)-min(x)+.02))

sam<-sample(1:(len+ntest))
train<-dat[sam[1:len],]
test<-dat[sam[(len+1):(len+ntest)],]

d<-dim(train)[2]
####################

#MEG
#

cc<-cov(train)
rho_start<- max( abs(cc-diag(diag(cc))) )

run_seq <- exp( seq(from=log(rho_start*.2), to =log(rho_start*1.1),length.out=100 ) )
#run_seq<- seq(from=1e-5,to=rho_start,length.out=25)
test_error<- vector(length=length(run_seq))
ind=0

glasso_out<-glassopath(s=cc,
                       rholist=run_seq)$wi

glasso_out_relax<-mcmapply(FUN=function(x){
  ge<-get.edgelist(
    graph.adjacency( (glasso_out[,,x]==0),
                     mode="undirected")
  )
  if(dim(ge)[1]==0) ge<-NULL
  glasso(s=cc,
         rho=1e-5*rho_start,
         zero=ge
  )$wi
},
x=1:length(run_seq),
SIMPLIFY="array"
)

test_error<-mcmapply(FUN=function(x){
  print(x)
  -mean( apply(test,1,function(xx)gaussian_lik(xx-colMeans(test),glasso_out[,,x])))
},
x=1:length(run_seq),
SIMPLIFY=T,
mc.cores=cores
)

test_error_relax<-mcmapply(FUN=function(x){
  print(x)
  -mean( apply(test,1,function(xx)gaussian_lik(xx-colMeans(test),glasso_out_relax[,,x])))
},
x=1:length(run_seq),
SIMPLIFY=T,
mc.cores=cores
)

num_nonzero<-mapply(function(x)(sum(glasso_out[,,x]!=0) -d)/2,x=1:length(run_seq))
num_nonzero_relax<-mapply(function(x)(sum(glasso_out_relax[,,x]!=0) -d)/2,x=1:length(run_seq))

which.min(test_error_relax)
which.min(test_error)
min(test_error);min(test_error_relax)

####################
#fit path for trw
#
########################################

#edgelist<- get.edgelist( graph.full(d,directed=F) )
#g<-   erdos.renyi.game(d,2/d); #  g<- g+g
#g<-graph.empty(d)
g<-graph.full(d,directed=F)
edgelist<- get.edgelist(g)
clust<- clusters(g)$membership

edge_mean <- edge.means(train, edgelist, m2, cores)
node_mean <- node.means(train , m1,cores)
edge_mean_test <- edge.means(test, edgelist, m2, cores)
node_mean_test <- node.means(test , m1,cores)
weights<- rep(1, dim(edgelist)[1])  #rep(1,dim(edgelist)[1])

edge_coef<- array(0,dim=c(m2,m2,dim(edgelist)[1]))
node_coef<- matrix(0,d,m1)

lambda=.1
alpha_start=1

path<-trw_path(edge_coef,node_coef,node_mean,edge_mean,
               edgelist,weights=NULL,alpha_start=1,
               g,cores=cores,limit=limit,relax=F,edge.opt=T,out_len=out_len)
path_relax<-trw_path(edge_coef,node_coef,node_mean,edge_mean,
                     edgelist,weights=NULL,alpha_start=1,
                     g,cores=cores,limit=limit,relax=T,edge.opt=T,out_len=out_len)

risk_path<-lapply(path,function(x){
  -trw_lik(node_mean_test,edge_mean_test[,,x$eind,drop=F],x$vert_coef,x$edge_coef,x$part_fn)
})
risk_path_relax<-lapply(path_relax,function(x){
  -trw_lik(node_mean_test,edge_mean_test[,,x$eind,drop=F],x$vert_coef,x$edge_coef,x$part_fn)
})

risk_path<-simplify2array(risk_path)
risk_path_relax<-simplify2array(risk_path_relax)

seqlm<-  seqlp<-round( seq(from=1,to=limit,length.out=out_len) )

mcl<-densityMclust(train)
mixlik(test,mcl$parameters)
graphs = forestDensityEst(train, 2*d)
likehd_out = computeLogLikehd(train, test, list(graphs));

likehd_out$likehd_ls
#mixlik(test,mcl$parameters)

setwd("~/trw/Experiments")

save.image("meg.rdata")

pdf("path_meg.pdf")
# nf<- layout(matrix(c(1,1,1,2,3,4),nrow=2,ncol=3,byrow=T), respect = T,heights=c(8,6),widths=rep(4,3))
#
# plot(seqlm,risk_path,type="l",ylim=range(risk_path,risk_path_relax,test_error))
# points(seqlm,risk_path_relax,type="l",col="blue")
# #points(seqlm,risk_path_tree,type="l",col="orange")
#
# points(num_nonzero,test_error_relax,col="green",type="l")
# points(num_nonzero,test_error,col="purple",type="l")
# legend("topright",c("trw","trw relax","glasso relax", "glasso"),
#        pch=16,col=c("black","blue","green","purple"))
#dev.off()

########################################
#g1<- graph.adjacency(h$theta,mode="undirected")
g1<- graph.empty(122,directed=F)
g2<- graph.edgelist(path_relax[[which.min(risk_path_relax)]]$edgelist,directed=F)
#g3<-graph.adjacency(1*(glasso_out[,,57]!=0)-diag(d),
#                mode="undirected")
#g2<-graph.edgelist(path_relax[[6]]$edgelist,directed=F)
g3ind=which.min(abs(apply(glasso_out,3,function(x) sum(x[row(x)>=col(x)+1]!=0))-199))
g3<-graph.adjacency(1*(glasso_out[,,g3ind]!=0)-diag(d),
                mode="undirected")
l<-layout.auto(graph.union(g3,g2))
#l<-layout.auto(g2)
g12<- graph.union(g1,g2)
g13<- graph.union(g1,g3)

el1 <- apply(get.edgelist(g1), 1, paste, collapse="-")
el2 <- apply(get.edgelist(g2), 1, paste, collapse="-")
el3 <- apply(get.edgelist(g3), 1, paste, collapse="-")
el12 <- apply(get.edgelist(g12), 1, paste, collapse="-")
el13 <- apply(get.edgelist(g13), 1, paste, collapse="-")
E(g1)$color= "black"
#E(g12)$color <- ifelse( !(el12 %in% el1)  , "red",
#		ifelse(!(el12 %in% el2), "gray", "black") )
E(g3)$color <- ifelse( (el3 %in% el2)  , "black","red")
	#	ifelse(!(el13 %in% el3), "red", "black") )
E(g2)$color="black"
E(g3)$color="black"
edge.lty12 <- ifelse( (el12 %in% el2), "solid","solid")
edge.lty13 <- ifelse( (el13 %in% el3), "solid","solid")

lec <- leading.eigenvector.community(g2)
lev <- lec$membership
rb=rainbow(5)
k=1
cut=sort(unlist(lapply(unique(lev),function(x)sum(x==lev))),decreasing=T)[4]

for(i in unique(lev)){
	if(sum(lev==i)<cut) V(g2)$color[lev==i] = "black"
	else{
		V(g2)$color[lev==i]=rb[k]
		k=k+1
	}
}

lec <- leading.eigenvector.community(g3)
lev <- lec$membership
k=1

cut=sort(unlist(lapply(unique(lev),function(x)sum(x==lev))),decreasing=T)[4]
for(i in unique(lev)){
	if(sum(lev==i)<cut) V(g3)$color[lev==i] = "black"
	else{
		V(g3)$color[lev==i]=rb[c(1,3,2,4)][k]
		k=k+1
	}
}
#pdf("graph_gaussian.pdf")
#par(mfcol=c(1,3))

par(mar=rep(.5,4),mfcol=c(2,1) )
# plot.igraph(g1,vertex.size=5,
#      layout=l,
#      vertex.label='',
#      edge.color="black",
#      edge.lty=1,
#      vertex.color="white");
#      title("True",line=-2)
plot.igraph(g2,
     layout=l,
     vertex.label='',
     edge.lty=edge.lty12,
     #vertex.color="black",
     vertex.size=4,
     edge.width=.02);
 #   title("TRW")

plot.igraph(g3,
     layout=l,
     vertex.label='',
     edge.lty=edge.lty13,
     #vertex.color="black",
     vertex.size=4,
     edge.width=.02
	)
          #title("Glasso")

dev.off()

# g12<- graph.union(g1,g2)
# g13<- graph.union(g1,g3)
#
# el1 <- apply(get.edgelist(g1), 1, paste, collapse="-")
# el2 <- apply(get.edgelist(g2), 1, paste, collapse="-")
# el3 <- apply(get.edgelist(g3), 1, paste, collapse="-")
# el12 <- apply(get.edgelist(g12), 1, paste, collapse="-")
# el13 <- apply(get.edgelist(g13), 1, paste, collapse="-")
# E(g1)$color= "black"
# E(g12)$color <- ifelse( !(el12 %in% el1)  , "red",
# 		ifelse(!(el12 %in% el2), "gray", "black") )
# E(g13)$color <- ifelse( !(el13 %in% el1)  , "red",
# 		ifelse(!(el13 %in% el3), "gray", "black") )
# edge.lty12 <- ifelse( (el12 %in% el2), "solid","solid")
# edge.lty13 <- ifelse( (el13 %in% el3), "solid","solid")
#
#
# pdf("graph_meg.pdf")
# par(mfcol=c(1,3))
# plot(g1,vertex.size=2,
#      layout=l,
#      vertex.label='',
#      edge.color="black",
#      edge.lty=1);
# plot(g12,vertex.size=2,
#      layout=l,
#      vertex.label='',
#      edge.lty=edge.lty12);
# plot(g13,vertex.size=2,
#      layout=l,
#      vertex.label='',
#      edge.lty=edge.lty13);
# dev.off()
#
#
# pdf("mi_weightng_meg.pdf")
# plot(path[[which.min(risk_path)]]$mutual_info,path[[which.min(risk_path)]]$weight,pch=16)
# dev.off(


library(cluster)
library(caret)
library(purrr)
library(dplyr)
library(boot)
#library(table1)
library(Hmisc)

data=read.csv("/mnt/workspace/DCRI/Data/analysis_ds.csv")
train=data[which(data$train==1),]
#colnames(train)
base_nmiss=train[complete.cases(train[, c(1:3, 5, 6, 9:19, 20:22, 50, 51)]), c(1:3, 5, 6, 9:19, 20:22, 50, 51)]
studyn=base_nmiss$study.1
enrolid=base_nmiss[,1]
base_nmiss=base_nmiss[, -c(1,7,8,20,21)]
#base_nmiss=base_nmiss[, -c(1,9,10,22,23)]
ppr=preProcess(base_nmiss, method=c('center','scale'))

#apply transformations
base_scale=predict(ppr, newdata=base_nmiss)

#base_scale=scale(base_nmiss)

test=data[which(data$test==1),]
test_nmiss=test[complete.cases(test[, c(1:3, 5, 6, 9:19, 20:22, 50, 51)]), c(1:3, 5, 6, 9:19, 20:22, 50, 51)]
test_studyn=test_nmiss$study.1
test_enrolid=test_nmiss[,1]
test_nmiss=test_nmiss[, -c(1,7,8,20,21)]
#base_nmiss=base_nmiss[, -c(1,9,10,22,23)]
#test_scale=scale(_nmiss)
test_scale=predict(ppr, newdata=test_nmiss)

set.seed(123)

# function to compute total within-cluster sum of square
wss <- function(k) {
  kmeans(base_scale, k, iter.max=20, nstart = 4)$tot.withinss
}

# Compute and plot wss for k = 1 to k = 15
k.values <- 2:15

# extract wss for 2-15 clusters
wss_values <- map_dbl(k.values, wss)

plot(k.values, wss_values,
       type="b", pch = 19, frame = FALSE,
       xlab="Number of clusters K",
       ylab="Total within-clusters sum of squares")

#going to use 4 or 5 clusters

set.seed(123)
cluster1 <- kmeans(base_scale, 4, iter.max=15, nstart = 6)
cluster2 <- kmeans(base_scale, 5, iter.max=15, nstart = 6)

base_nmiss %>%
  mutate(Cluster = cluster1$cluster) %>%
  group_by(Cluster) %>%
  summarise_all("mean")

base_nmiss %>%
  mutate(Cluster = cluster2$cluster) %>%
  group_by(Cluster) %>%
  summarise_all("mean")

#table(base_nmiss$studyn, final$cluster)
check=data.frame(person_id=enrolid, study=studyn, cluster1=cluster1$cluster, cluster2=cluster2$cluster)
#head(check)
table(check$study, check$cluster1)
table(check$study, check$cluster2)

#table(base_nmiss$studyn, final$cluster)
predict.kmeans <- function(object,
                           newdata,
                           method = c("centers", "classes")) {
  method <- match.arg(method)

  centers <- object$centers
  ss_by_center <- apply(centers, 1, function(x) {
    colSums((t(newdata) - x) ^ 2)
  })
  best_clusters <- apply(ss_by_center, 1, which.min)

  if (method == "centers") {
    centers[best_clusters, ]
  } else {
    best_clusters
  }
}

pred1=predict.kmeans(cluster1, newdata=test_scale, method="classes")
pred2=predict.kmeans(cluster2, newdata=test_scale, method="classes")
std=data.frame(person_id=test_enrolid, study=test_studyn, cluster1=pred1, cluster2=pred2)
#head(std)
table(std$study, std$cluster1)
table(std$study, std$cluster2)

#train2=left_join(x=train, y=check, by='person_id')
#colnames(train)
#head(train)
#test2=left_join(x=test, y=std, by='person_id')

#all=rbind(train2, test2)
#head(all)
#write.csv(all, file='/mnt/workspace/DCRI/Data/analysis_ds_clusters.csv', quote = FALSE,  row.names = FALSE)


##############################################################################################
###  Genotype-phenotype overlap (GPO): heterozygosity per individual                       ###
##                                     filter when +- 5 standard deviation (SD) from mean  ###
###  2009, David Ellinghaus, d.ellinghaus@ikmb.uni-kiel.de                                 ###
##############################################################################################

## read arguments from command line
file.het <- commandArgs()[4]

## - read data - #
ds.het <- read.table(file=file.het, as.is=T, header=T)
dim(ds.het)

heterozygosity <- 1 - ds.het[,3]/ds.het[,5]

length(heterozygosity)
summary(heterozygosity)
het.mean <- mean(heterozygosity)
# heterozygosity +- 5SD way from mean
het.sd_5times <- 5 * sd(heterozygosity, na.rm = FALSE)
print(het.sd_5times)

upper_bound  <- het.mean + het.sd_5times
downer_bound <- het.mean - het.sd_5times

output <- paste(file.het, ".outlier.txt",sep="")
sink (file=output)

for (i in 1:length(heterozygosity)) {
  if (heterozygosity[i] < downer_bound || heterozygosity[i] > upper_bound) {
    cat(ds.het[i,1], ds.het[i,2], heterozygosity[i], "\n")
  }
}
sink ()

###################################################################
###  END OF SCRIPT  ###############################################
###################################################################


## RPM - Hierarchical GLM  ##
# logistic regression heterogeneity on coefficients
policy.RPM.Logit.Heter <- function(m,y,...){

  d$impressions <- m
  d$conversions <- y

  me <- glmer( cbind(conversions,impressions-conversions) ~ size + concept + size:concept + (0+concept|placeid),
              family=binomial(link="logit"), data=d,  glmerControl(optCtrl = list(maxfun=1000)) )

  d.long <- d[ rep(1:nrow(d), each=n.iters), ]
  d.long$iternum <- rep( 1:n.iters, nrow(d) )

concept.names <- levels(d$concept)
concept_each <- factor(rep(levels(d$concept),3))
size_each <- factor(rep(levels(d$size),each=4))
creative.names <- paste(size_each, concept_each, sep="_")
designmatrix <- cbind(model.matrix( ~ size_each )[,-1],
                      model.matrix( ~ concept_each)[,-1]
                      )

designmatrix.interactions <- model.matrix( ~ size_each*concept_each)[,-1]
rownames(designmatrix.interactions) <- creative.names
desmat <- designmatrix.interactions

est.fitted <- fitted(me)

vc <- VarCorr(me)
ranef.se <- sqrt( diag(vc$placeid) )
names(ranef.se) <- paste("ranef_se_", names(diag(vc$placeid)),sep="")

ranef.mean.mat <- ranef(me)$placeid
ranef.se.mat <- se.ranef(me)$placeid
ranef.est.mean <- c(t(ranef.mean.mat))
ranef.est.var <- c(t(ranef.se.mat^2))
ranef.coef.samp.wide <- mvrnorm(n.iters, ranef.est.mean, diag(ranef.est.var) ) #mvrnorm(n, mu, Sigma)
ranef.coef.samp <- c(ranef.coef.samp.wide) # append column over column
d.long$ranef.coef.samp <- ranef.coef.samp

fixef.est.coef <- fixef(me)
fixef.est.varcov <- vcov(me)
fixef.coef.samp <- mvrnorm(n.iters, fixef.est.coef, fixef.est.varcov)
fixef.linpred.samp.wide <- fixef.coef.samp  %*% t(cbind(rep(1,nrow(desmat)),desmat))
fixef.linpred.samp <- rep(0, nrow(d)*n.iters)
for (place in levels(d$placeid) ){
  for (conc in levels(d$concept) ){
    curobslong <- which(d.long$placeid==place & d.long$concept==conc)
    sandc <- unique(d.long$sizeandconcept[curobslong])
    fixef.linpred.samp[ curobslong ] <- fixef.linpred.samp.wide[,sandc]
  }
}
d.long$fixef.linpred.samp <- fixef.linpred.samp

# sample linear predictors for whole dataset from whole model
linpred.samp <- fixef.linpred.samp + ranef.coef.samp
cvr.samp <- exp(linpred.samp)/( 1 + exp(linpred.samp) )

d.long$linpred.samp <- linpred.samp
d.long$cvr.samp <- cvr.samp

d.long$iter <- paste("iter", rep(n.iters*10+ 1:n.iters , nrow(d) ) ,sep="")
d.long$placeid_iter <- paste(d.long$placeid, d.long$iter, sep="_")

zstar.samp <- linpred.samp
zstar.which.max.perplaceid <- tapply(zstar.samp, INDEX=d.long$placeid_iter, FUN=which.max)
zstar.which.max.perplaceid.table <- table( zstar.which.max.perplaceid, rep(levels(d$placeid),each=n.iters) )

alloc.probs.table <- zstar.which.max.perplaceid.table/n.iters

outallocprob <- as.numeric( zstar.which.max.perplaceid.table /n.iters)

w <- outallocprob
paramvec <- data.frame( coef=fixef.coef.samp , linpred=matrix(linpred.samp,nrow=n.iters) )

return(list(w=w,paramvec=paramvec))

}


#' Calculate actual performance of methods
#'
#' This function calculates actual performance of a given set of learners using
#' a user-defined gold standard. If problem type is binary this calculates
#' balanced accuracy, if it is of ranks then the performance measure is AUC.
#' @param summa A summa object created by the summa() function
#' @param true_val A numeric vector of samples corresponding to true labels with 1
#' representing positive class and -1 representing negative class.
#' @return An object of class summa
#' @examples
#' load(system.file("extdata", "example_rank.Rdata", package = "UnsupervisedEnsemble"))
#' summa=summa(rank_matrix,"rank")
#' summa=calculate_performance(summa,actual_labels,"rank")
#' @export

calculate_performance<-function(summa,true_val,nrandom=50)
{
if(summa@type == "binary")
{
predictions=summa@predictions
performance_all=apply(predictions,2,calculate_ba,true_val=true_val)
summa@actual_performance=as.matrix(performance_all)
summa@woc=calculate_ba(apply(predictions,1,mean),true_val)
summa@summa=calculate_ba(predictions %*% summa@weights,true_val)
summa@summa_combined_performance=get_combination_scores(summa,true_val)
summa@woc_combined_performance=get_random_woc_performance(summa,true_val,nrandom)
}
else if(summa@type == "rank")
{
predictions=summa@predictions
performance_all=apply(predictions,2,calculate_auc,true_val=true_val)
summa@actual_performance=as.matrix(performance_all)
summa@woc=calculate_auc(apply(predictions,1,mean),true_val)
summa@summa=calculate_auc(as.vector(predictions %*% summa@weights),true_val)
summa@summa_combined_performance=get_combination_scores(summa,true_val)
summa@woc_combined_performance=get_random_woc_performance(summa,true_val,nrandom)
}

return(summa)
}

get_combination_scores <- function(summa, true_val)
{
type=summa@type
nmethods=summa@nmethods
summa_combined_performance=as.vector(matrix(0,nmethods,1))
idx_1=which.max(summa@estimated_performance)
summa_combined_performance[1]=summa@actual_performance[idx_1]
idx=order(abs(summa@estimated_performance),decreasing=TRUE)
predictions=summa@predictions
if(type=="binary")
{

for(i in 2:length(idx))
{
summa_combined_performance[i]=calculate_ba(as.vector(predictions[,idx[1:i]] %*% summa@weights[idx[1:i]]),true_val)
#woc_combined_performance[i]=calculate_ba(apply(predictions[,idx[1:i]],1,mean) ,true_val)

}
}

if(type=="rank")
{
  for(i in 2:length(idx))
  {
summa_combined_performance[i]=calculate_auc(as.vector(predictions[,idx[1:i]] %*% summa@weights[idx[1:i]]),true_val)
#woc_combined_performance[i]=calculate_auc(apply(predictions[,idx[1:i]],1,mean) ,true_val)
}
}

return(summa_combined_performance)
}

get_random_woc_performance <- function(summa,true_val,nrandom=50)
{
  type=summa@type
  nmethods=summa@nmethods
  predictions=summa@predictions
  woc_combined_performance=matrix(0,nmethods*nrandom,2)
  colnames(woc_combined_performance)=c("n_methods","performance")
  kk=1

  for(i in 1:nmethods)
  {
  for (j in 1:nrandom)
  {
  woc_combined_performance[kk,1]=i
  idx=sample(1:nmethods,i,replace=FALSE)

  if(type=="binary")
  {
  woc_combined_performance[kk,2]=calculate_ba(apply(as.matrix(predictions[,idx]),1,mean) ,true_val)
  }

  if(type=="rank")
  {
  woc_combined_performance[kk,2]=calculate_auc(apply(as.matrix(predictions[,idx]),1,mean) ,true_val)
  }

  kk=kk+1
  }

  }

  return(woc_combined_performance)
}

calculate_auc <- function(predict, true_val)
{
roc_obj <- suppressMessages( pROC::roc(true_val, predict,direction=">"))
auc=roc_obj$auc[1]
return(auc)
}

# compute balanced accuracy
calculate_ba <- function(predict, true_val)
{
  pp <- which(predict >= 0)
  p  <- which(true_val >= 0)
  pn <- which(predict < 0)
  n   <- which(true_val < 0)
  tpr=length(intersect(pp,p))/length(p)
  tnr=length(intersect(pn,n))/length(n)
  ba=0.5*(tpr + tnr)
  return(ba)
}

get_SE <- function(x) {
  v <- c( mean(x) - sd(x)/sqrt(length(x)), mean(x), mean(x) + sd(x)/sqrt(length(x)))
  names(v) <- c("ymin",  "middle",  "ymax")
  v
}

# ===============================================================
# ===============================================================
# rates
# ===============================================================
# ===============================================================

#####  Calculate AUC
#####
#####


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

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

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

Type 'demo()' for some demos, 'help()' for on-line help, or
'help.start()' for an HTML browser interface to help.
Type 'q()' to quit R.
 install.packages("depmixS4")
 library(depmixS4)
 install.packages("quantmod")
 library(quantmod)
 install.packages("ggplot2")
 library(ggplot2)

 EuroUSD <- read.csv("d:/EURUSD1d.csv", header = TRUE)

 head(EuroUSD)

 summary(EuroUSD)

 str(EuroUSD)

 Date <- as.character(EuroUSD[,1])

 DateTimeSeries <- as.POSIXlt(Date, format = "%Y.%m.%d %H:%M:%S")

 TimeSeriesData <- data.frame(EuroUSD[,2:5], row.names = DateTimeSeries)

 head(TimeSeriesData)

 TimeSeriesData <-as.xts(TimeSeriesData)

 ATRindicator <- ATR(TimeSeriesData[,2:4],n=14)

 head(ATRindicator)

 TrueRange <- ATRindicator[,2]

 head(TrueRange)

 LogReturns <- log(EuroUSD$Close) - log(EuroUSD$Open)

 summary(LogReturns)

 HMMModel <- data.frame(LogReturns, TrueRange)

 HMMModel <- HMMModel[-c(1:14),]

 head(HMMModel)

 colnames(HMMModel) <- c("LogReturns","TrueRange")

 colnames(HMMModel)

 set.seed(1)

 HMM <- depmix(list(LogReturns~1, TrueRange~1), data = HMMModel, nstates=3, family=list(gaussian(), gaussian()))

 HMMfit <- fit(HMM, verbose = FALSE)

 print(HMMfit)

 summary(HMMfit)

 HMMstate <- posterior(HMMfit)

 head(HMMstate)

 DFIndicators <- data.frame(DateTimeSeries, LogReturns, TrueRange)

 DFIndicatorsClean <- DFIndicators[-c(1:14), ]

 Plot1Data <- data.frame(DFIndicatorsClean, HMMstate$state)

 LogReturnsPlot <- ggplot(Plot1Data,aes(x=Plot1Data[,1],y=Plot1Data[,2]))+geom_line(color="darkred")+labs(title="Euro USD Daily Log Returns",y="Log Return Values",x="Date")
 LogReturnsPlot


setwd("/Users/kat/github/benchmark_quantifiers/files")
library(limma)
d = read.csv("transcript_metrics_ENS.PD.txt_new",sep="\t", row.names = 1)
head(d)
medium_length_fpkm = d$FPKM
d = read.csv("transcript_metrics_ENS.PLD.txt",sep="\t", row.names = 1)
head(d)
long_length_fpkm = d$FPKM
k = cbind(medium_length_fpkm,long_length_fpkm)
plotMA(k, main = "MVA plot - Medium vs. Long",ylab = "Expression log-ratio")
d = read.csv("transcript_metrics_ENS.PSD.txt_new",sep="\t", row.names = 1)
head(d)
short_length_fpkm = d$FPKM
k = cbind(medium_length_fpkm,short_length_fpkm)
plotMA(k, main = "MVA plot - Medium vs. Short",ylab = "Expression log-ratio")


library("methods")
library("metap")
{{rimport}}('__init__.r')
options(stringsAsFactors = FALSE)

infile  = {{i.infile | R}}
outfile = {{o.outfile | R}}
intype  = {{args.intype | R}}
inopts  = {{args.inopts | R}}
method  = {{args.method | R}}
na      = {{args.na | R}}
if (method == 'fisher') {
	method = 'sumlog'
}

indata = read.table.inopts(infile, inopts)
if (intype == 'matrix') {
	entries = rownames(indata)
	if (is.null(entries)) {
		entries = 1:nrow(indata)
	}
} else {
	entries = levels(factor(indata[,1]))
}

ret = data.frame(Entry = character(), N = numeric(), MetaPval = numeric())
for (entry in entries) {
	if (intype == 'matrix') {
		pvals = indata[entry,]
	} else {
		pvals = indata[which(indata[,1] == entry), 2]
	}
	pvals = na.omit(pvals)
	lenps = length(pvals)
	if (lenps < 1) {
		ret = rbind(ret, list(Entry = entry, N = 0, MetaPval = NA))
	} else if (lenps == 1) {
		ret = rbind(ret, list(Entry = entry, N = 1, MetaPval = pvals))
	} else {
		ret = rbind(ret, list(Entry = entry, N = length(pvals), MetaPval = do.call(method, list(pvals))$p))
	}
}

write.table(pretty.numbers(ret, list(MetaPval = '%.2E')), outfile, row.names = F, col.names = T, sep = "\t", quote = F)


# WMO papers on air pressure reduction suggest an influence of temperature
# change on air pressure. This analysis is meant to verify that.

logger.names <- grep('barometer/', gwloggeR.data::enumerate(), value = TRUE)

logger.names <- setdiff(logger.names, 'barometer/BAOL016X_W1666.csv')
logger.names <- setdiff(logger.names, 'barometer/BAOL050X_56819.csv') # high freq manu in range of 80 cmH2O

round_timestamp <- function(ts, scalefactor.sec = 3600*12) {
  as.POSIXct(round(as.numeric(ts)/scalefactor.sec) * scalefactor.sec, origin = '1970-01-01', tz = 'UTC')
}

read.baro <- function(logger.name) {
  df <- gwloggeR.data::read(logger.name)$df

  df <- df[!is.na(TIMESTAMP_UTC), ]
  df <- df[!is.na(TEMPERATURE_VALUE), ]
  df <- df[!is.na(PRESSURE_VALUE), ]
  df <- df[!duplicated(TIMESTAMP_UTC), ]

  if (nrow(df) == 0L) return(df)

  # df <- df[, .('PRESSURE_VALUE' = mean(PRESSURE_VALUE),
  #              'TEMPERATURE_VALUE' = mean(TEMPERATURE_VALUE)),
  #          by = .('TIMESTAMP_UTC' = round_timestamp(TIMESTAMP_UTC))]

  # Filter
  df <- df[PRESSURE_VALUE < 1100,]
  df <- df[PRESSURE_VALUE > 975,]

  # Meta data
  df[, 'FILE' := basename(logger.name)]
  df[, 'N' := .N]

  data.table::setkey(df, TIMESTAMP_UTC)

  # Changes in TEMP and PRESSURE
  df[, 'TEMPERATURE_VALUE_DIFF' := TEMPERATURE_VALUE - data.table::shift(TEMPERATURE_VALUE)]
  df[, 'PRESSURE_VALUE_DIFF' := PRESSURE_VALUE - data.table::shift(PRESSURE_VALUE)]
  df[, 'TIMESTAMP_DIFF_SEC' := as.numeric(TIMESTAMP_UTC - data.table::shift(TIMESTAMP_UTC), units = 'secs')]
  df <- df[-1L, ]

  data.table::setkey(df, TIMESTAMP_UTC)

  structure(df, 'logger.name' = logger.name)
}

df.list <- sapply(logger.names, read.baro)

df <- data.table::rbindlist(df.list, use.names = TRUE, fill = TRUE)
df <- df[TIMESTAMP_DIFF_SEC <= 12*3600]
df <- df[abs(TEMPERATURE_VALUE_DIFF) <= 70]
df <- df[abs(PRESSURE_VALUE_DIFF) <= 100]

ggplot2::ggplot(data = df, mapping = ggplot2::aes(x = TEMPERATURE_VALUE_DIFF, y = PRESSURE_VALUE_DIFF)) +
  ggplot2::geom_point(pch = '.') +
  #ggplot2::stat_smooth(method = 'gam', color = 'yellow', se = FALSE) +
  #ggplot2::stat_smooth(method = 'gam', formula = y ~ s(x, k = 5), color = 'yellow', se = FALSE) +
  #ggplot2::geom_smooth(method = 'lm', formula = y ~ x + I(x^2), col = 'yellow', size = 1.2, alpha = 0.9) +
  ggplot2::geom_quantile(quantiles = 0.5, formula = y ~ x + I(x^2), col = 'blue', size = 1.2, alpha = 0.9) +
  ggplot2::coord_cartesian(xlim = quantile(df$TEMPERATURE_VALUE_DIFF, probs = c(0.0001, 0.9999)),
                           ylim = quantile(df$PRESSURE_VALUE_DIFF, probs = c(0.0001, 0.9999))) +
  ggplot2::theme_light()

summary((fit.lm <- lm(data = df, formula = PRESSURE_VALUE_DIFF ~ TEMPERATURE_VALUE_DIFF + I(TEMPERATURE_VALUE_DIFF^2))))
summary((fit.rq <- quantreg::rq(data = df, formula = PRESSURE_VALUE_DIFF ~ TEMPERATURE_VALUE_DIFF +  + I(TEMPERATURE_VALUE_DIFF^2))))


library(forecast)
fraser <- scan("fraser.txt")
plot(fraser)
fraser.ts <- ts(fraser, frequency=12, start=c(1913,3))
fraser.stl = stl(fraser.ts, s.window="periodic")
monthplot(fraser.stl)
seasonplot(fraser.ts)


library(MASS)
matrix_from_list <- function (x,y) matrix(x, nrow=y)
inverseFromList <- function(x,y) ginv(matrix_from_list(x,y))
inverse_mean <- function (x) ginv(x)


##### Chapter 2: Managing and Understanding Data -------------------

##### R data structures --------------------

## Vectors -----

# create vectors of data for three medical patients
subject_name <- c("John Doe", "Jane Doe", "Steve Graves")
temperature <- c(98.1, 98.6, 101.4)
flu_status <- c(FALSE, FALSE, TRUE)

# access the second element in body temperature vector
temperature[2]

## examples of accessing items in vector
# include items in the range 2 to 3
temperature[2:3]

# exclude item 2 using the minus sign
temperature[-2]

# use a vector to indicate whether to include item
temperature[c(TRUE, TRUE, FALSE)]

## Factors -----

# add gender factor
gender <- factor(c("MALE", "FEMALE", "MALE"))
gender

# add blood type factor
blood <- factor(c("O", "AB", "A"),
                levels = c("A", "B", "AB", "O"))
blood

## Lists -----

# display information for a patient
subject_name[1]
temperature[1]
flu_status[1]
gender[1]
blood[1]

# create list for a patient
subject1 <- list(fullname = subject_name[1],
                 temperature = temperature[1],
                 flu_status = flu_status[1],
                 gender = gender[1],
                 blood = blood[1])

# display the patient
subject1

## methods for accessing a list

# get a single list value by position
subject1[2]
# get a single list value by name
subject1$temperature

# get several list items by specifying a vector of names
subject1[c("temperature", "flu_status")]

## access a list like a vector
# get values 4 and 5
subject1[4:5]

## Data frames -----

# create a data frame from medical patient data

pt_data <- data.frame(subject_name, temperature, flu_status, gender,
                      blood, stringsAsFactors = FALSE)

# display the data frame
pt_data

## accessing a data frame

# get a single column
pt_data$subject_name

# get several columns by specifying a vector of names
pt_data[c("temperature", "flu_status")]

# this is the same as above, extracting temperature and flu_status
pt_data[2:3]

# accessing by row and column
pt_data[1, 2]

# accessing several rows and several columns using vectors
pt_data[c(1, 3), c(2, 4)]

## Leave a row or column blank to extract all rows or columns

# column 1, all rows
pt_data[, 1]
# row 1, all columns
pt_data[1, ]
# all rows and all columns
pt_data[ , ]

# the following are equivalent to the above
pt_data[c(1, 3), c("temperature", "gender")]
pt_data[-2, c(-1, -3, -5)]

## Matrixes -----

# create a 2x2 matrix
m <- matrix(c('a', 'b', 'c', 'd'), nrow = 2)
m

# equivalent to the above
m <- matrix(c('a', 'b', 'c', 'd'), ncol = 2)
m

# create a 2x3 matrix
m <- matrix(c('a', 'b', 'c', 'd', 'e', 'f'), nrow = 2)
m

# create a 3x2 matrix
m <- matrix(c('a', 'b', 'c', 'd', 'e', 'f'), ncol = 2)
m

# extract values from matrixes
m[1, 1]
m[3, 2]

# extract rows
m[1, ]

# extract columns
m[, 1]

##### Exploring and understanding data --------------------

## data exploration example using used car data
usedcars <- read.csv("usedcars.csv", stringsAsFactors = FALSE)

# get structure of used car data
str(usedcars)

## Exploring numeric variables -----

# summarize numeric variables
summary(usedcars$year)
summary(usedcars[c("price", "mileage")])

# calculate the mean income
(36000 + 44000 + 56000) / 3
mean(c(36000, 44000, 56000))

# the median income
median(c(36000, 44000, 56000))

# the min/max of used car prices
range(usedcars$price)

# the difference of the range
diff(range(usedcars$price))

# IQR for used car prices
IQR(usedcars$price)

# use quantile to calculate five-number summary
quantile(usedcars$price)

# the 99th percentile
quantile(usedcars$price, probs = c(0.01, 0.99))

# quintiles
quantile(usedcars$price, seq(from = 0, to = 1, by = 0.20))

# boxplot of used car prices and mileage
boxplot(usedcars$price, main="Boxplot of Used Car Prices",
      ylab="Price ($)")

boxplot(usedcars$mileage, main="Boxplot of Used Car Mileage",
      ylab="Odometer (mi.)")

# histograms of used car prices and mileage
hist(usedcars$price, main = "Histogram of Used Car Prices",
     xlab = "Price ($)")

hist(usedcars$mileage, main = "Histogram of Used Car Mileage",
     xlab = "Odometer (mi.)")

# variance and standard deviation of the used car data
var(usedcars$price)
sd(usedcars$price)
var(usedcars$mileage)
sd(usedcars$mileage)

## Exploring numeric variables -----

# one-way tables for the used car data
table(usedcars$year)
table(usedcars$model)
table(usedcars$color)

# compute table proportions
model_table <- table(usedcars$model)
prop.table(model_table)

# round the data
color_table <- table(usedcars$color)
color_pct <- prop.table(color_table) * 100
round(color_pct, digits = 1)

## Exploring relationships between variables -----

# scatterplot of price vs. mileage
plot(x = usedcars$mileage, y = usedcars$price,
     main = "Scatterplot of Price vs. Mileage",
     xlab = "Used Car Odometer (mi.)",
     ylab = "Used Car Price ($)")

# new variable indicating conservative colors
usedcars$conservative <-
  usedcars$color %in% c("Black", "Gray", "Silver", "White")

# checking our variable
table(usedcars$conservative)

# Crosstab of conservative by model
CrossTable(x = usedcars$model, y = usedcars$conservative)


;; ==========================================
;; Script: date-time.r
;; downloaded from: www.REBOL.org
;; on: 14-May-2017
;; at: 8:21:19.889817 UTC
;; owner: fvzv [script library member who can
;; update this script]
;; ==========================================
;; ==================================================
;; email address(es) have been munged to protect them
;; from spam harvesters.
;; If you were logged on the email addresses
;; would not be munged
;; ==================================================
REBOL [
	file: %date-time.r
	title: "Date and time functions"
	date: 24-Feb-2011
	version: 1.1
	home: http://rebol.x10.mx
	author: "Francois Vanzeveren"
	email: %brainois--rebol--x10--mx
	purpose: {
		This script contains the Rebol implementation of some date and time functions provided in
		the glibc library and the gnumeric (and therefore Microsoft Excel) software.
		While the use and handling of date and time data are in most cases straightforward
		with Rebol, some of the advanced date and times functionalities found in glibc and
		gnumeric are still missing in Rebol.
		This script is therefore an attempt to fill the gap.
	}
	language: "English"
	history: [
		1.1 24-Feb-2011 "Francois Vanzeveren" {
			BUG: the function 'week-of-year was not correctly implemented, sometimes
				returning 0 as week number for the first week of the year.
			CLEANSING: iso-week-num removed (redundant with week-of-year/iso)
		}
		1.0 05-Jan-2003 "Francois Vanzeveren" "First public release"
	]
	library: [
		level: 'intermediate
		platform: 'all
		type: [function tool]
		domain: [extension financial]
		tested-under: [linux windows]
		support: none
		license: 'lgpl
		see-also: none
	]
]
;					M T W T F S S
;_base-monday: copy [1 2 3 4 5 6 7]
_base-sunday: copy [2 3 4 5 6 7 1]

end-of-month: function [
{
	Returns the last day of the month which is @months from the @start-date.
}
	start-date [date!]
	months [integer!]
] [
	last-day [integer!]
	new-month [integer!]
	new-year [integer!]
] [
	either greater-or-equal? months 0 [
		new-year: add start-date/year to-integer divide add start-date/month months 12
		new-month: remainder add start-date/month months 12
	] [
		either greater? start-date/month absolute months [
			new-year: start-date/year
			new-month: add start-date/month months
		] [
			new-year: add start-date/year subtract to-integer divide add start-date/month months 12 1
			new-month: add 12 remainder add start-date/month months 12
		]
	]
	last-day: multiply 31 to-integer found? find [0 1 3 5 7 8 10 12] new-month
	if all [not to-logic last-day found? find [4 6 9 11] new-month ] [
		last-day: 30
	]
	if not to-logic last-day [
		last-day: add 28 to-integer leap-year? make date! reduce [1 1 new-year]
	]
	make date! reduce [last-day new-month new-year]
]

end-of-month?: function [
{
	Returns true if @a-date is the last day of its month.
}
	a-date [date!]
] [] [
	equal? a-date end-of-month a-date 0
]

leap-year?: function [
{
	Returns true for a leap year.
}
	date [date!] "The date to check."
] [year [integer!]] [
	 year: date/year
	 any [
		 all [
			 equal? 0 remainder year 4
			 not-equal? 0 remainder year 100
		 ]
		 equal? 0 remainder year 400
	 ]
]

date-dif: function [
{
	Returns the difference between two dates.
}
	date1 [date!]
	date2 [date!]
	/y	{Returns the number of complete years between @date1 and @date2.}
	/m	{Returns the number of complete months between @date1 and @date2.}
	/d	{Returns the number of complete days between @date1 and @date2.}
	/ym	{Returns the number of full months between @date1 and @date2,
		not including the difference in years.}
	/md	{Returns the number of full days between @date1 and @date2,
		not including the difference in months.}
	/yd	{Returns the number of full days between @date1 and @date2,
		not including the difference in years.}
] [] [
	if y [
		return
		subtract
		subtract date2/year date1/year
		to-integer	any [ 	lesser? date2/month date1/month
							all [	equal? date2/month date1/month
									lesser? date2/day date1/day
							]
					]
	]
	if m [
		return
		subtract
		subtract
		add
		multiply
		subtract date2/year date1/year
		12
		date2/month
		date1/month
		to-integer lesser? date2/day date1/day
	]
	if ym [
		return
		either any [lesser? date1/month date2/month
					all [ equal? date1/month date2/month
						lesser-or-equal? date1/day date2/day
					]
		] [
			subtract
			subtract date2/month date1/month
			to-integer greater? date1/day date2/day
		] [
			subtract
			add
			subtract 12 date1/month
			date2/month
			to-integer greater? date1/day date2/day
		]
	]
	if md [
		return
		subtract
		add date2/day
		multiply get-refinement end-of-month date2 -1 'day to-integer greater? date1/day date2/day
		date1/day
	]
	if yd [
		if all [equal? date1/day date2/day
				equal? date1/month date2/month
		] [ return 0 ]
		return
		either any [
			greater? date2/month date1/month
			all [
				equal? date2/month date1/month
				greater? date2/day date1/day
			]
		] [
			use [ start-date [date!]] [
				start-date: make date! reduce [date1/day date1/month date2/year]
				subtract date2 start-date
			]
		] [
			use [ start-date [date!]] [
				start-date: make date! reduce [date1/day date1/month subtract date2/year 1 ]
				subtract date2 start-date
			]
		]
	]

	return subtract date2 date1
]

days360: function [
{
	Returns the number of days from @date1 to @date2
	following a 360-day calendar in which all months
	are assumed to have 30 days. By default, the US method is used.
}
	date1 [date!] "Starting date"
	date2 [date!] "Ending date"
	/euro {The European method will be used. In this case, if the day of
		the month is 31 it will be considered as 30.}
	/us {U.S. (NASD) method. If the starting date is the 31st of a month,
		it becomes equal to the 30th of the same month. If the ending
		date is the 31st of a month and the starting date is earlier
		than the 30th of a month, the ending date becomes equal to
		the 1st of the next month, otherwise the ending date becomes
		equal to the 30th of the same month.
		This is the default behaviour.}
] [] [
	either euro [
		;euro
		date1: subtract date1 to-integer equal? date1/day 31
		date2: subtract date2 to-integer equal? date2/day 31
	] [
		;US or default
		either all [
			end-of-month? date1
			end-of-month? date2
		] [
			date1/day: min date1/day date2/day
			date2/day: min date1/day date2/day
		] [
			date1: subtract date1 to-integer all [
				equal? date1/day 31
				any [ not-equal? date1/month date2/month
					not-equal? date1/year date2/year
					equal? date2/day 30
				]
			]
			if all [ equal? date1/month 2 ; February
				equal? date1/day 29 ; End of february for leap year...
				greater-or-equal? date2 subtract end-of-month date1 0 1
				any [ not-equal? date1/month date2/month
					not-equal? date1/year date2/year
				]
			] [
				date2: subtract date2 1
			]
			if equal? date2/day 31 [
				either lesser? date1/day 30 [
					date2: add date2 1
				][
					date2: subtract date2 1
				]
			]
		]
	]
	return
		add
		add
		multiply date-dif/m date1 date2 30
		multiply 30 to-integer lesser? date2/day date1/day
		subtract date2/day date1/day
]

edate: function [
{
	Returns the date that is the specified number of months
	before or after a given date.
}
	initial-date [date!] "The initial date."
	months [integer!] {The number of months before (negative number) or
		after (positive number) the initial date.}
] [
	new-day [integer!]
	new-month [integer!]
	new-year [integer!]
	new-date [integer!]
] [
	new-day: initial-date/day
	new-month: remainder add initial-date/month months 12
	new-year: add initial-date/year to-integer divide add initial-date/month months 12
	new-date: end-of-month make date! reduce [1 new-month new-year] 0
	if lesser? new-day new-date/day [
		new-date/day: new-day
	]
	return new-date
]

day-of-year: function [
{
	Returns the day number within @the-date/year.
	The first day of the year has value 1.
}
	the-date [date!]
] [] [
	add 1 subtract the-date make date! reduce [the-date/year 1 1]
]

week-of-year: function [
{
	Return the week of the year.
	The first week of the year has value 1.
}
	the-date [date!]
	/monday "Weeks are understood to start on Monday"
	/sunday "Weeks are understood to start on Sunday."
	/iso {Returns the ISO 8601 week number of @the-date.
		An ISO 8601 week starts on Monday. Weeks are numbered from 1.
		Week 01 of a year is per definition the first week that
		has the Thursday in this year, which is equivalent to
		the week that contains the fourth day of January. In other
		words, the first week of a new year is the week that has
		the majority of its days in the new year. Week 01 might also
		contain days from the previous year and the week before week
		01 of a year is the last week (52 or 53) of the previous year
		even if it contains days from the new year.
		See http://www.techno-science.net/?onglet=glossaire&definition=3075
	}
] [
	week [integer!]
	wd [integer!]
	day [integer!]
	jan1date [date!]
	mon [date!]
	thur [date!]
] [
	either iso [
		thur: add the-date
				subtract 4 the-date/weekday
		mon: make date! reduce [thur/year 1 4]
		mon: add mon
				subtract 1 mon/weekday
		week: round/ceiling divide subtract thur mon 7
	] [
		jan1date: make date! reduce [the-date/year 1 1]
		wd: jan1date/weekday ; Weeks are understood to start on Monday
		if sunday [
			; Weeks are understood to start on Sunday
			wd: pick _base-sunday wd
		]
		wd: subtract wd 1
		day: subtract day-of-year the-date 1
		week: add 1 to-integer divide add day wd 7
	]

	week ; return value
]

net-work-days: function [
{
	Returns the number of whole working days, beginning with
	@start_date and ending with @end_date, excluding days in
	@dates and weekends.
}
	start-date [date!]
	end-date [date!]
	/holidays dates [block!]
] [
	nb-of-holidays [integer!]
	diff-in-weeks [integer!]
	first-week-nwd [integer!] ; first week non weekend days
	last-week-nwd [integer!] ; last week non weekend days
	non-weekend-days [integer!]
	first-monday [date!] ; the first monday of the period, first week not included.
	last-friday [date!] ; the last friday of the period, last week not included.
] [
	if greater? start-date end-date [
		use [tmp-date [date!]] [
			tmp-date: end-date
			end-date: start-date
			start-date: tmp-date
		]
	]

	nb-of-holidays: 0
	if holidays [
		; Computes the number of holidays within the period
		foreach item dates [
			if all [
				date? item
				lesser-or-equal? item/weekday 5 ; saturday and sunday are not holidays, but weekend days
				greater-or-equal? item start-date
				lesser-or-equal? item end-date
			][
				nb-of-holidays: add nb-of-holidays 1
			]
		]
	]

	; number of non weekend days during the first week of the period
	first-week-nwd: multiply
		to-integer lesser-or-equal? start-date/weekday 5
		add 1 subtract 5 start-date/weekday
	; number of non weekend days during the last week of the period
	last-week-nwd: either lesser-or-equal? end-date/weekday 5 [ end-date/weekday ] [5]

	; the first monday of the period, first week not included.
	first-monday: add start-date add 1 subtract 7 start-date/weekday
	; the last friday of the period, last week not included.
	last-friday: subtract end-date add 2 end-date/weekday

	non-weekend-days: either greater? last-friday first-monday [
		diff-in-weeks: to-integer divide add 1 subtract last-friday first-monday 7
		add first-week-nwd
		add last-week-nwd
		add 5 multiply 5 diff-in-weeks
	] [
		subtract
			add first-week-nwd last-week-nwd
			multiply 5 to-integer equal?
				subtract end-date/weekday start-date/weekday
				subtract end-date start-date ; start-date and end-date are in the same week!
	]
	; return value
	subtract non-weekend-days nb-of-holidays
]

work-day: function [
{
	Returns the day which is @days working days from the @start-date.
	Weekends and holidays optionally supplied in @dates are respected.
}
	start-date [date!]
	days [integer!]
	/holidays dates [block!]
] [
	weekend-days [integer!]
	end-date [date!]
	days-gap [integer!]
] [
	if not holidays [
		dates: make block! []
	]
	weekend-days: multiply 2
		subtract
			to-integer divide days 5
			to-integer equal? remainder days 5 0

	end-date: add start-date add days weekend-days
	days-gap: add 1 subtract absolute days net-work-days/holidays start-date end-date dates
	while [ not-equal? days-gap 0 ] [
		end-date: either positive? days [add end-date days-gap] [subtract end-date days-gap]
		days-gap: add 1 subtract absolute days net-work-days/holidays start-date end-date dates
	]
	if negative? days [
		while [found? find dates end-date] [
			end-date: add end-date 1
		]
	]
	; return value
	end-date
]


# create a 10 sided die
die_10 <- 1:10

# how many rounds will there be?
n_rounds <- 100

# how many players will there be?
n_players <- 4

# variable to hold the current round's highest score & the player who scored it
current_round_best_score <- 0
current_round_leader <- NA

# make a null vector to record each round's winner
winners <- rep(NA, n_rounds)

# go through however many rounds there are
for (i in 1:n_rounds){
  # have each player roll
  for (p in 1:n_players){
    # roll & sum the outcome
    outcome <- sample(die_10, 2, replace=FALSE)
    outcome <- sum(outcome)

    # check if this player rolled more than the previous leader
    if (outcome > current_round_best_score){
      # replace this round's high score & leader if they've been beaten
      current_round_best_score <- outcome
      current_round_leader <- p
    }
  }
  # record the round's winner
  winners[i] <- current_round_leader

  # reset the high score
  current_round_best_score <- 0
  current_round_leader <- NA
}

# create a table of results
results = table(winners)
# results = summary(as.factor(winners))
results


if choosePhyllUse =="Default":
    if (leafNumber < ldecr): phyllochron = fixPhyll * pdecr
    elif (leafNumber >= ldecr and leafNumber < lincr): phyllochron = fixPhyll
    else: phyllochron = fixPhyll * pincr
if choosePhyllUse =="PTQ":
    pastMaxAI1 = pastMaxAI
    gai = max(pastMaxAI1,gai)
    pastMaxAI = gai
    if (gai > 0.0): phyllochron = phylPTQ1 * ((gai * kl) / (1 - exp(-kl * gai))) / (ptq + aPTQ)
    else: phyllochron = phylPTQ1
if choosePhyllUse == "Test":
    if (leafNumber < ldecr): phyllochron = p * pdecr
    elif (leafNumber >= ldecr and leafNumber < lincr): phyllochron = p
    else: phyllochron = p * pincr


gev.fit2 <- function (xdat, ydat = NULL, mul = NULL, sigl = NULL, shl = NULL,
    mulink = identity, siglink = identity, shlink = identity,
    muinit = NULL, siginit = NULL, shinit = NULL, show = TRUE,
    method = "Nelder-Mead", maxit = 10000, ndeps = 1e-6, ...)
{
  # modification of gev.fit() from ismev by C. Paciorek
  # differences from gev.fit()
  # (1) has params be scalar when no covariates to improve computational efficiency - this only makes much difference in speed when the data vector is fairly long
  # (2) robustly handles NAs in xdat
  # (3) modifies initial values for log link
  # (4) adds 'flag' output that indicates if MLE or standard errors may not be legitimate
  # (5) allows one to change the default step size of the finite difference approximation to the gradient in the optimization

  z <- list()
  npmu <- length(mul) + 1
  npsc <- length(sigl) + 1
  npsh <- length(shl) + 1
  z$trans <- FALSE
  in2 <- sqrt(6 * var(xdat, na.rm=T))/pi
  in1 <- mean(xdat, na.rm=T) - 0.57722 * in2
  if(identical(mulink, exp))
    in1 = log(in1)
  if(!identical(mulink, exp) && !identical(mulink, identity))
    warning("Default initial value for location is on incorrect scale; please supply your own.")
  if(identical(siglink, exp))
    in2 = log(in2)
  if(!identical(siglink, exp) && !identical(siglink, identity))
    warning("Default initial value for scale is on incorrect scale; please supply your own.")
  shinit.default = 0.1
  if(identical(shlink, exp))
    shinit.default = log(shinit.default)
  if(!identical(shlink, exp) && !identical(shlink, identity))
    warning("Default initial value for shape is on incorrect scale; please supply your own.")

  if (is.null(mul)) {
    mumat <- 1  # as.matrix(rep(1, length(xdat)))
    if (is.null(muinit))
      muinit <- in1
  } else {
    z$trans <- TRUE
    mumat <- cbind(rep(1, length(xdat)), ydat[, mul])
    if (is.null(muinit))
      muinit <- c(in1, rep(0, length(mul)))
  }
  if (is.null(sigl)) {
    sigmat <- 1 # as.matrix(rep(1, length(xdat)))
    if (is.null(siginit))
      siginit <- in2
  } else {
    z$trans <- TRUE
    sigmat <- cbind(rep(1, length(xdat)), ydat[, sigl])
    if (is.null(siginit))
      siginit <- c(in2, rep(0, length(sigl)))
  }
  if (is.null(shl)) {
    shmat <- 1  # as.matrix(rep(1, length(xdat)))
    if (is.null(shinit))
      shinit <- shinit.default
  } else {
    z$trans <- TRUE
    shmat <- cbind(rep(1, length(xdat)), ydat[, shl])
    if (is.null(shinit))
      shinit <- c(shinit.default, rep(0, length(shl)))
  }
  z$model <- list(mul, sigl, shl)
  z$link <- deparse(substitute(c(mulink, siglink, shlink)))
  init <- c(muinit, siginit, shinit)
  gev.lik <- function(a) {
    mu <- c(mulink(mumat %*% (a[1:npmu])))
    sc <- c(siglink(sigmat %*% (a[seq(npmu + 1, length = npsc)])))
    xi <- c(shlink(shmat %*% (a[seq(npmu + npsc + 1, length = npsh)])))
    y <- (xdat - mu)/sc
    y <- 1 + xi * y
    if (any(y <= 0, na.rm = TRUE) || any(sc <= 0))
      return(10^6)
    if(length(sc) == 1){
      l <- length(xdat[!is.na(xdat)]) * log(sc)
    } else{
      l <- sum(log(sc[!is.na(xdat)]))
    }
    l <- l + sum(y^(-1/xi), na.rm = TRUE) + sum(log(y) * (1/xi + 1), na.rm = TRUE)
    return(l)
  }
  x <- optim(init, gev.lik, hessian = TRUE, method = method,
             control = list(maxit = maxit, ndeps = rep(ndeps, length = length(init)), ...))
  z$conv <- x$convergence
  mu <- c(mulink(mumat %*% (x$par[1:npmu])))
  sc <- c(siglink(sigmat %*% (x$par[seq(npmu + 1, length = npsc)])))
  xi <- c(shlink(shmat %*% (x$par[seq(npmu + npsc + 1, length = npsh)])))
  z$nllh <- x$value
  z$data <- xdat
  if (z$trans) {
    z$data <- -log(as.vector((1 + (xi * (xdat - mu))/sc)^(-1/xi)))
  }
  z$mle <- x$par
  z$cov <- solve(x$hessian)
  z$se <- sqrt(diag(z$cov))
  z$vals <- cbind(mu, sc, xi)
  if (show) {
    if (z$trans)
      print(z[c(2, 3, 4)])
    else print(z[4])
    if (!z$conv)
      print(z[c(5, 7, 9)])
  }
  z$flag = 0
  if(sum(is.na(c(z$mle, z$se))) || min(xi) < -1 || min(z$se) < 1e-5){
    z$flag = 1
    warning("MLEs and standard errors may not be reliable; please check convergence, estimates, standard errors, and input data.")
  }
  class(z) <- "gev.fit"
  invisible(z)
}


romanToArabic <- function(roman) {
  romanLookup <- c(I=1L, V=5L, X=10L, L=50L, C=100L, D=500L, M=1000L)
  rSplit <- strsplit(toupper(roman), character(0)) # Split input vector into characters
  toArabic <- function(item) {
    digits <- romanLookup[item]
    if (length(digits) > 1L) {
      smaller <- (digits[-length(digits)] < digits[-1L])
      digits[smaller] <- - digits[smaller]
    }
    sum(digits)
  }
  vapply(rSplit, toArabic, integer(1))
}


# Advanced data challenges

# A. Uniformity
# 1. Date uniformity
# dplyr and lubridate are loaded and accounts is available
# Check out the accounts data frame
head(accounts)

# Define the date formats
formats <- c("%Y-%m-%d", "%B %d, %Y")

# Convert dates to the same format
accounts %>%
  mutate(date_opened_clean = parse_date_time(date_opened, orders = formats))

# 2. Currency uniformity
# dplyr and ggplot2 are loaded and the accounts and account_offices data frames are available
# Scatter plot of opening date and total amount
accounts %>%
  ggplot(aes(x = date_opened, y = total)) +
  geom_point()

# Left join accounts to account_offices by id
accounts %>%
  left_join(account_offices, by = "id") %>%
  # Convert totals from the Tokyo office to USD
  mutate(total_usd = ifelse(office == "Tokyo", total / 104, total)) %>%
  # Scatter plot of opening date vs total_usd
  ggplot(aes(x = date_opened, y = total_usd)) +
    geom_point()

# B. Cross field validation
# 1. Validating totals
# dplyr is loaded and accounts is available
# Find invalid totals
accounts %>%
  # theoretical_total: sum of the three funds
  mutate(theoretical_total = fund_A + fund_B + fund_C) %>%
  # Find accounts where total doesn't match theoretical_total
  filter(theoretical_total != total)

# 2. Validating age
# dplyr and lubridate are loaded, and accounts is available
# Find invalid acct_age
accounts %>%
  # theoretical_age: age of acct based on date_opened
  mutate(theoretical_age = floor(as.numeric(date_opened %--% today(), "years"))) %>%
  # Filter for rows where acct_age is different from theoretical_age
  filter(theoretical_age != acct_age)

# C. Completeness
# 1. Visualizing missing data
# The dplyr and visdat packages have been loaded and accounts is available
# Visualize the missing values by column
vis_miss(accounts)

accounts %>%
  # missing_inv: Is inv_amount missing?
  mutate(missing_inv = is.na(inv_amount)) %>%
  # Group by missing_inv
  group_by(missing_inv) %>%
  # Calculate mean age for each missing_inv group
  summarize(avg_age = mean(age))

# Sort by age and visualize missing vals
accounts %>%
  arrange(age) %>%
  vis_miss()

# 2. Treating missing data
# dplyr and assertive are loaded and accounts is available
# Create accounts_clean
accounts_clean <- accounts %>%
  # Filter to remove rows with missing cust_id
  filter(!is.na(cust_id)) %>%
  # Add new col acct_amount_filled with replaced NAs
  mutate(acct_amount_filled = ifelse(is.na(acct_amount), inv_amount * 5, acct_amount))

# Assert that cust_id has no missing vals
assert_all_are_not_na(accounts_clean$cust_id)

# Assert that acct_amount_filled has no missing vals
assert_all_are_not_na(accounts_clean$acct_amount_filled)


# 4. faza: Analiza podatkov

#-----------------------------------------------------------------------------------------------------------------------------------------------
# Model rasti za elektriko in zemeljski plin
#-----------------------------------------------------------------------------------------------------------------------------------------------

elektrika_TD <- elektrika_TDa
plin_TD <- plin_TDa

names(elektrika_TD) <- c("a","b")
elektrika_TD$a <- as.numeric(as.character(elektrika_TD$a))
elektrika_TD$b <- as.numeric(as.character(elektrika_TD$b))

names(plin_TD) <- c("a","b")
plin_TD$a <- as.numeric(as.character(plin_TD$a))
plin_TD$b <- as.numeric(as.character(plin_TD$b))

modelelektrika <- lm(data=elektrika_TD, b ~ a)
napoved <- predict(modelelektrika, data.frame(a=c(2020, 2021, 2022, 2023, 2024, 2025)))
elektrika_TD1 <- elektrika_TD
elektrika_TD1 <- data.frame(a = c(2020, 2021, 2022, 2023, 2024, 2025),
                            b = c(napoved[1], napoved[2], napoved[3], napoved[4], napoved[5], napoved[6]))

names(elektrika_TD1) <- c("a", "b")

elektrika_TD$vrsta1 <- "podatki"
elektrika_TD1$vrsta1 <- "napoved"
elektrika_TD <- rbind(elektrika_TD, elektrika_TD1)
elektrika_TD$energent <- "Električna energija"

names(elektrika_TD) <- c("leto_in_cetrtletje", "cena_(EUR/kWh)", "vrsta", "energent")

modelplin <- lm(data=plin_TD, b ~ a)
napoved2 <- predict(modelplin, data.frame(a=c(2020, 2021, 2022, 2023, 2024, 2025)))
plin_TD1 <- plin_TD
plin_TD1 <- data.frame(a = c(2020, 2021, 2022, 2023, 2024, 2025),
                            b = c(napoved2[1], napoved2[2], napoved2[3], napoved2[4], napoved2[5], napoved2[6]))

names(plin_TD1) <- c("a", "b")

plin_TD$vrsta2 <- "podatki"
plin_TD1$vrsta2 <- "napoved"
plin_TD <- rbind(plin_TD, plin_TD1)
plin_TD$energent <- "Zemeljski plin"

names(plin_TD) <- c("leto_in_cetrtletje", "cena_(EUR/kWh)", "vrsta", "energent")

rownames(elektrika_TD) <- 1:nrow(elektrika_TD)
rownames(plin_TD) <- 1:nrow(plin_TD)

tabelanapovedi <- rbind(elektrika_TD, plin_TD)
tabelanapovedi$leto_in_cetrtletje <- as.numeric(as.character(tabelanapovedi$leto_in_cetrtletje))
tabelanapovedi$`cena_(EUR/kWh)` <- as.numeric(as.character(tabelanapovedi$`cena_(EUR/kWh)`))

#-----------------------------------------------------------------------------------------------------------------------------------------------
# Model rasti za deleže gospodinjstev
#-----------------------------------------------------------------------------------------------------------------------------------------------

poraba_TD1 <- TD_poraba_gospodinjstev %>% filter(energetski_vir == "Toplota iz okolice (TJ)")
poraba_TD2 <- TD_poraba_gospodinjstev %>% filter(energetski_vir == "Sončna energija (TJ)")
poraba_TD3 <- TD_poraba_gospodinjstev %>% filter(energetski_vir == "Daljinska toplota (TJ)")
poraba_TD1$energetski_vir <- NULL
poraba_TD2$energetski_vir <- NULL
poraba_TD3$energetski_vir <- NULL
poraba_TD1$leto <- as.numeric(as.character(poraba_TD1$leto))
poraba_TD2$leto <- as.numeric(as.character(poraba_TD1$leto))
poraba_TD3$leto <- as.numeric(as.character(poraba_TD1$leto))

# Toplota
modelporabetoplote <- lm(data=poraba_TD1, poraba ~ log(leto))
napoved3 <- predict(modelporabetoplote, data.frame(leto=c(2019, 2020, 2021, 2022, 2023, 2024, 2025, 2026, 2027, 2028, 2029, 2030)))
poraba_TD4 <- poraba_TD1
poraba_TD4 <- data.frame(leto = c(2019, 2020, 2021, 2022, 2023, 2024, 2025, 2026, 2027, 2028, 2029, 2030),
                            poraba = c(napoved3[1], napoved3[2], napoved3[3], napoved3[4], napoved3[5], napoved3[6], napoved3[7], napoved3[8],
                                       napoved3[9], napoved3[10], napoved3[11], napoved3[12]))
poraba_TD1 <- rbind(poraba_TD1, poraba_TD4)
names(poraba_TD1) <- c("leto", "porabatoplote")

# Sončna energija
modelporabesonca <- lm(data=poraba_TD2, poraba ~ log(leto))
napoved4 <- predict(modelporabesonca, data.frame(leto=c(2019, 2020, 2021, 2022, 2023, 2024, 2025, 2026, 2027, 2028, 2029, 2030)))
poraba_TD5 <- poraba_TD2
poraba_TD5 <- data.frame(leto = c(2019, 2020, 2021, 2022, 2023, 2024, 2025, 2026, 2027, 2028, 2029, 2030),
                         poraba = c(napoved4[1], napoved4[2], napoved4[3], napoved4[4], napoved4[5], napoved4[6], napoved4[7], napoved4[8],
                                    napoved4[9], napoved4[10], napoved4[11], napoved4[12]))
poraba_TD2 <- rbind(poraba_TD2, poraba_TD5)
names(poraba_TD2) <- c("leto", "porabasoncne")

# Daljinska toplota
modelporabedaljinske <- lm(data=poraba_TD3, poraba ~ log(leto))
napoved5 <- predict(modelporabedaljinske, data.frame(leto=c(2019, 2020, 2021, 2022, 2023, 2024, 2025, 2026, 2027, 2028, 2029, 2030)))
poraba_TD6 <- poraba_TD3
poraba_TD6 <- data.frame(leto = c(2019, 2020, 2021, 2022, 2023, 2024, 2025, 2026, 2027, 2028, 2029, 2030),
                         poraba = c(napoved5[1], napoved5[2], napoved5[3], napoved5[4], napoved5[5], napoved5[6], napoved5[7], napoved5[8],
                                    napoved5[9], napoved5[10], napoved5[11], napoved5[12]))
poraba_TD3 <- rbind(poraba_TD3, poraba_TD6)
names(poraba_TD3) <- c("leto", "porabadaljinske")

tabelanapovedi2 <- merge(poraba_TD1, poraba_TD2, by=c("leto"))
tabelanapovedi2 <- merge(tabelanapovedi2, poraba_TD3, by=c("leto"))

tabelanapovedi2$celotnaporaba <- with(tabelanapovedi2, porabatoplote + porabasoncne + porabadaljinske)
tabelanapovedi2$od1 <- with(tabelanapovedi2, 100 * porabatoplote / celotnaporaba)
tabelanapovedi2$od2 <- with(tabelanapovedi2, 100 * porabasoncne / celotnaporaba)
tabelanapovedi2$od3 <- with(tabelanapovedi2, 100 * porabadaljinske / celotnaporaba)

names(tabelanapovedi2) <- c("leto", "poraba1", "poraba2", "poraba3", "celotnaporaba", "Toplota iz okolice (%)", "Sončna energija (%)", "Daljinska toplota (%)")

tabelanapovedi2 <- tabelanapovedi2 %>% gather("energent","odstotek", 6:8)

#-----------------------------------------------------------------------------------------------------------------------------------------------
# Grafi
#-----------------------------------------------------------------------------------------------------------------------------------------------
colors <- c("cena_elektrike_(EUR/kWh)" = "blue", "cena_plina_(EUR/kWh)" = "red")

graf3 <- ggplot(data=tabelanapovedi, aes(x=leto_in_cetrtletje, y=`cena_(EUR/kWh)`, col=energent)) +
  geom_point(aes(shape = vrsta), size = 2, ) + geom_line() + xlab('leto') + ylab('cena (EUR/kWh)') + ggtitle('Napoved cene plina in elekrike') +
  geom_smooth(method="lm", aes(y=`cena_(EUR/kWh)`))

graf6 <- ggplot(data=tabelanapovedi2, aes(x=leto, y=odstotek, fill=energent)) +
  geom_bar(stat="identity", palette = "Blues") + xlab('leto') + ylab('letna poraba (%)') + ggtitle('Deleži porab, merljivih v TJ') +
  scale_fill_manual("Legenda", values = c("Toplota iz okolice (%)" = "#173F5F", "Sončna energija (%)" = "#20639B", "Daljinska toplota (%)" = "#3CAEA3"))