library(raster)
library(rgdal)
library(rgeos)
library(tidyverse)
memory.limit(size=1e9)

exclusion_zones.rs <- raster("P:/is-wel/indus/message_indus/input/percent_grid_cell_available_wind_solar.asc")
plot(exclusion_zones.rs)
#just to have a reference coordinate system, otherwise area function gives wanrning
indus_basin.spdf = readOGR("P:/is-wel/indus/message_indus/input",'Indus_bcu')
proj4string(exclusion_zones.rs) <- proj4string(indus_basin.spdf)
area.rs <- area(exclusion_zones.rs)

turbine_density = 5 # max MW installed per sqkm from IRENA; this is consistent with Eurek et al.
panel_density = 30 # Pietzcker et al claims 100 MW/km2 and provides values by country, but this seems very optimistic
#   Ong et al (2013) claims roughly 30 MW/km2 for large (>20 MW) PV plants; However, to be consistent with Pietzcker,
#   which was used for the global potentials, the Pietzcker value for a representative country in each basin
#   is used (e.g. Pakistan for Indus).

# potential in MW  <- km^2    * [0-1]             * MW/km^2
max_wind_potential <- area.rs * exclusion_zones.rs * turbine_density
plot(max_wind_potential)
max_solar_potential <- area.rs * exclusion_zones.rs * panel_density
plot(max_solar_potential)

# load capacity factors
# make exclusion zones values 0 or 1
bin_exclusion_zones.rs <- exclusion_zones.rs
bin_exclusion_zones.rs[bin_exclusion_zones.rs > 0 ] = 1

solar.df <- read.csv("P:/is-wel/indus/message_indus/input/LF/solar_monthly_LF.csv")
months = unique(solar.df$month)
# make spdf
solar.df <- solar.df %>% select(-id) %>%
  spread(month,value)
solar.spdf <- solar.df
coordinates(solar.spdf) = ~ lon + lat

gridded(solar.spdf) = TRUE
plot(solar.spdf)

solar.st = do.call(stack, lapply( months, function(mm){ return( raster( solar.spdf[,mm] ) ) } ) )

solar.st = resample(solar.st, bin_exclusion_zones.rs, method="bilinear")
# pdf("P:/is-wel/indus/message_indus/input/LF/solar_lf_no_exclusion.pdf")
# plot(solar.st)
# dev.off()
solar.st = solar.st * (bin_exclusion_zones.rs )
# pdf("P:/is-wel/indus/message_indus/input/LF/solar_lf_after_exclusion.pdf")
# plot(solar.st)
# dev.off()

wind.df <- read.csv("P:/is-wel/indus/message_indus/input/LF/wind_monthly_LF.csv")
wind.df <- wind.df %>% select(-id) %>%
  spread(month,value)
wind.spdf <- wind.df
coordinates(wind.spdf) = ~ lon + lat

gridded(wind.spdf) = TRUE
plot(wind.spdf)

wind.st = do.call(stack, lapply( months, function(mm){ return( raster( wind.spdf[,mm] ) ) } ) )

wind.st = resample(wind.st, bin_exclusion_zones.rs, method="bilinear")
pdf("P:/is-wel/indus/message_indus/input/LF/wind_lf_no_exclusion.pdf")
plot(wind.st)
dev.off()
wind.st = wind.st * (bin_exclusion_zones.rs )
pdf("P:/is-wel/indus/message_indus/input/LF/wind_lf_after_exclusion.pdf")
plot(wind.st)
dev.off()

## gather and fit for gams

make_spatial_with_PID <- function(raster_in,mapping.spdf){
coords <- as.data.frame(coordinates(raster_in),StringAsFactor = F)
out.df <- as.data.frame(raster_in,StringAsFactor = F)
out.spdf <- out.df
coordinates(out.spdf) <- coords
proj4string(out.spdf) <- proj4string(mapping.spdf)
out.spdf = spTransform( out.spdf, crs(mapping.spdf) )

out.spdf <- out.spdf[!is.na(out.spdf@data[,1]),]
out.spdf <- out.spdf[out.spdf@data[,1] != 0,]

out.spdf@data$PID <- as.character(over(out.spdf,mapping.spdf[,"PID"])$PID)
#out.spdf@data$PID <- as.numeric(out.spdf@data$PID[,1])
names(out.spdf)[length(names(out.spdf))] = 'PID'
return(out.spdf)
}

PIDs <- over(out.spdf,mapping.spdf[,"PID"])[1]
solar_out.spdf <- make_spatial_with_PID(solar.st,indus_basin.spdf)
b = solar_out.spdf@data
max_solar.spdf <- make_spatial_with_PID(max_solar_potential,indus_basin.spdf)
#@####### check from here!!
solar_out.df <- bind_cols(as.data.frame(coordinates(solar_out.spdf),row.names = NULL), solar_out.spdf@data) %>%
  filter(!is.na(PID)) %>%
  select(x,y,PID,everything()) %>%
  gather(key = month, value = value,4:15) %>%
  group_by(x,y) %>%
  mutate(annual_lf = mean(value)) %>%
  ungroup()

#hist(solar_out.df$annual_lf)
q_solar <-solar_out.df %>% select(PID,annual_lf) %>%
  group_by(PID) %>%
  mutate(q1 = as.numeric(quantile(annual_lf,probs = c(0.33,0.66,1))[1])) %>%
  mutate(q2 = as.numeric(quantile(annual_lf,probs = c(0.33,0.66,1))[2])) %>%
  select(-annual_lf) %>%
  ungroup() %>% distinct()

solar_out.df<- solar_out.df %>%
  left_join(q_solar) %>%
  group_by(PID) %>%
  mutate(tec = if_else(annual_lf <= q1,"solar_1",
                       if_else(annual_lf > q1 & annual_lf <= q2,"solar_2",
                               if_else(annual_lf > q2,"solar_3","NO")) ) ) %>%
  select(-q1,-q2) %>%
  ungroup()

solar_agg.df <- solar_out.df %>%
  mutate(month = gsub(".*layer.","",month)) %>%
  group_by(PID,tec,month) %>%
  summarize(LF = mean(value)) %>%
  ungroup()

## assign to area file the technologies 1,2,3
max_solar.df <- bind_cols(as.data.frame(coordinates(max_solar.spdf),row.names = NULL), max_solar.spdf@data) %>%
  filter(!is.na(PID)) %>%
  left_join(solar_out.df %>% select(x,y,tec) %>% distinct(),by = c("x","y")) %>%
  filter(!is.na(tec)) %>%
  group_by(PID,tec) %>%
  summarise(MW = sum(layer))

## wind
wind_out.spdf <- make_spatial_with_PID(wind.st,indus_basin.spdf)
max_wind.spdf <- make_spatial_with_PID(max_wind_potential,indus_basin.spdf)
wind_out.df <- bind_cols(as.data.frame(coordinates(wind_out.spdf),row.names = NULL), wind_out.spdf@data) %>%
  filter(!is.na(PID)) %>%
  select(x,y,PID,everything()) %>%
  gather(key = month, value = value,4:15) %>%
  group_by(x,y) %>%
  mutate(annual_lf = mean(value)) %>%
  ungroup()

#hist(wind_out.df$annual_lf)
q_wind <-wind_out.df %>% select(PID,annual_lf) %>%
  group_by(PID) %>%
  mutate(q1 = as.numeric(quantile(annual_lf,probs = c(0.33,0.66,1))[1])) %>%
  mutate(q2 = as.numeric(quantile(annual_lf,probs = c(0.33,0.66,1))[2])) %>%
  select(-annual_lf) %>%
  ungroup() %>% distinct()

wind_out.df<- wind_out.df %>%
  left_join(q_wind) %>%
  group_by(PID) %>%
  mutate(tec = if_else(annual_lf <= q1,"wind_1",
                       if_else(annual_lf > q1 & annual_lf <= q2,"wind_2",
                               if_else(annual_lf > q2,"wind_3","NO")) ) ) %>%
  select(-q1,-q2) %>%
  ungroup()

wind_agg.df <- wind_out.df %>%
  mutate(month = gsub(".*layer.","",month)) %>%
  group_by(PID,tec,month) %>%
  summarize(LF = mean(value)) %>%
  ungroup()

## assign to area file the technologies 1,2,3
max_wind.df <- bind_cols(as.data.frame(coordinates(max_wind.spdf),row.names = NULL), max_wind.spdf@data) %>%
  filter(!is.na(PID)) %>%
  left_join(wind_out.df %>% select(x,y,tec) %>% distinct(),by = c("x","y")) %>%
  filter(!is.na(tec)) %>%
  group_by(PID,tec) %>%
  summarise(MW = sum(layer))

## save csv
max_cap_sw <- bind_rows(max_wind.df,max_solar.df)
names(max_cap_sw) = c("node",'tec',"value")
write.csv(max_cap_sw, file = "P:/is-wel/indus/message_indus/input/LF/max_capacity_sw.csv",
          row.names = F)

year<- c(1990	,2000	,2010	,2015	,2020	,2030	,2040	,2050	,2060	)
vintage <- year

year_nd_vint = expand.grid(year,vintage)

load_factor_sw <- bind_rows(wind_agg.df,solar_agg.df)
names(load_factor_sw) = c("node","tec","time","value")
write.csv(load_factor_sw, file = "P:/is-wel/indus/message_indus/input/LF/load_factor_sw.csv",
          row.names = F)


library(coop)

f = function(x, y, trans, inv)
{
  storage.mode(x) <- "double"
  storage.mode(y) <- "double"

  .Call("R_co_matmat", x, y, coop:::CO_VAR, FALSE, trans, inv)
}

x = matrix(rnorm(30), 10)
y = matrix(rnorm(30), 10)

a = f(x, y, F, F)
b = cov(x,y)
all.equal(a, b)

a = f(x, y, T, F)
b = cov(t(x), t(y))
all.equal(a, b)

# m = 1000
# n = 250
#
# x = matrix(rnorm(m*n), m, n)
# y = matrix(rnorm(m*n), m, n)
#
# library(rbenchmark)
#
# benchmark( f(x, y, T, F) )

g = function(x, y, trans, inv)
{
  storage.mode(x) <- "double"
  storage.mode(y) <- "double"

  .Call("R_co_matmat", x, y, coop:::CO_ORR, FALSE, trans, inv)
}

x = matrix(rnorm(30), 10)
y = matrix(rnorm(30), 10)

a = g(x, y, F, F)
b = cor(x,y)
all.equal(a, b)

a = g(x, y, T, F)
b = cor(t(x), t(y))
all.equal(a, b)

h = function(x, y, trans, inv)
{
  storage.mode(x) <- "double"
  storage.mode(y) <- "double"

  .Call("R_co_matmat", x, y, coop:::CO_SIM, FALSE, trans, inv)
}

set.seed(1234)
x = matrix(rnorm(30), 10)
y = matrix(rnorm(30), 10)

a = h(x, x, F, F)
b = cosine(x)
all.equal(a, b)

# a = h(x, y, T, F)
# b = cosine(t(x), t(y))
# all.equal(a, b)


=begin
[((<index-ja|URL:index-ja.html>))]
((<Algebra::Polynomial>))
/
((<Algebra::PolynomialFactorization>))
/
((<Algebra::SplittingField>))
/
((<Algebra::Galois>))

= Algebra::Polynomial
((*(1変数多項式環クラス)*))

1変数の多項式環を表現します。実際のクラスを生成するには環を指定して、クラスメソッド ((<::create>)) あるいは関数 ((<Algebra.Polynomial>))() を用います。

== ファイル名:
* ((|polynomial.rb|))

== スーパークラス:

* ((|Object|))

== インクルードしているモジュール:

* ((|Enumerable|))
* ((|Comparable|))
* ((<Algebra::EuclidianRing|URL:euclidian-ring-ja.html>))
* ((<Algebra::PolynomialFactorization>))
* ((<Algebra::SplittingField>))
* ((<Algebra::Galois>))

== 関連するメソッド:

--- Algebra.Polynomial(ring [, obj0 , obj1 [, ...]])
    ((<::create>))(ring, obj0[, obj1 [, ...]])> に同じ。

== クラスメソッド:

--- ::create(ring, obj0[, obj1[, ...]])
    ((|ring|)) で表現されるクラスを係数環とする多項式環クラスを
    生成します。

    (({obj0, obj1, ...})) で指定されたオブジェクトが変数を
    表現し、これが複数ならば、再帰的に多項式環上の多項
    式環を生成します。

    このメソッドの戻り値は Polynomial クラスのサブクラス
    です。このサブクラスにはクラスメソッドとして ((|ground|)) と
    ((|var|))、((|vars|)) が定義され、それぞれ、係数環 ((|ring|))、
    主変数オブジェクト（最後に指定された変数）、全ての変数オ
    ブジェクトを返します。

    オブジェクト(({obj0, obj1, ...}))は変数の名（((|to_s|))の値）
    に利用されるだけです。

    例: 整数を係数とする多項式環の生成
      require "polynomial"
      P = Algebra::Polynomial.create(Integer, "x")
      x = P.var
      p((x + 1)**100) #=> x^100 + 100x^99 + ... + 100x + 1
      p P.ground #=> integer

    例: 整数を係数とする複数変数多項式環の生成
      require "polynomial"
      P = Algebra::Polynomial.create(Integer, "x", "y", "z")
      x, y, z = P.vars
      p((-x + y + z)*(x + y - z)*(x - y + z))
      #=> -z^3 + (y + x)z^2 + (y^2 - 2xy + x^2)z - y^3 + xy^2 + x^2y - x^3
      p P.var #=> z

    この例の (({P})) は

      Algebra::Polynomial.create(
        Algebra::Polynomial.create(
          Algebra::Polynomial.create(
            Integer,
          "x"),
        "y"),
      "z")

    と同値で、最後の変数 ((|z|)) が主変数となります。

--- ::var
    多項式環の変数（主変数）を返します。

--- ::vars
    再帰的に各多項式環の変数を集めた配列を返します。

--- ::mvar
    ((<::vars>)) と同じです。

--- ::to_ary
    (({[self, *vars]})) を返します。

    例: 多項式環と変数を同時に定義する。
      P, x, y, z = Algebra::Polynomial.create(Integer, "x", "y", "z")

--- ::variable
    変数（主変数）を表現するオブジェクトを返します。

--- ::variables
    再帰的に各多項式環の変数を表現するオブジェクトを
    集めた配列を返します。

--- ::indeterminate(obj)
    ((|obj|)) で表現される変数を再帰的に探して返します。

--- ::monomial([n])
    ((|n|)) 次の単項式を返します。

    例:
      P = Algebra::Polynomial(Integer, "x")
      P.monomial(3) #=> x^3

--- ::const(c)
    値 ((|c|)) の定数項を返します。

    例:
      P = Algebra::Polynomial(Integer, "x")
      P.const(3)      #=> 3
      P.const(3).type #=> P

--- ::zero
    零元を返します。

--- ::unity
    単位元を返します。

#--- ::euclidian?

== メソッド:

--- var
    ((<::var>)) と同じです。

--- variable
    ((<::variable>)) と同じです。

--- each(&b)
    各次の係数を昇冪順に繰り返します。

    例:
      P = Algebra::Polynomial(Integer, "x")
      x = P.var
      (x**3 + 2*x**2 + 4).each do |c|
        p c #=> 4, 0, 2, 1
      end

--- reverse_each(&b)
    各次の係数を降冪順に繰り返します。

    例:
      P = Algebra::Polynomial(Integer, "x")
      x = P.var
      (x**3 + 2*x**2 + 4).reverse_each do |c|
        p c #=> 1, 2, 0, 4
      end

--- [](n)
    ((|n|)) 次の係数を返します。

--- []=(n, v)
    ((|n|)) 次の係数を((|v|))に設定します。

--- monomial
    ((<::monomial>)) と同じです。

--- monomial?
    単項式であるとき真を返します。

--- zero?
    零元であるとき真を返します。

--- zero
    零元を返します。

--- unity
    単位元を返します。

#--- variable=(bf)
#--- size
#--- compact!
#--- ground_div(n, d)

--- ==(other)
    等しいとき真を返します。

--- <=>(other)
    大小関係を求めます。

--- +(other)
    和を計算します。

--- -(other)
    差を計算します。

--- *(other)
    積を計算します。

--- **(n)
    ((|n|)) 乗を計算します。

--- /(other)
    商を計算します。((<div>))と同じです。

--- divmod(other)
    ((|other|)) で割った商と余りの配列を返します。

--- div(other)
    ((|other|)) で割った商を返します。(({divmod(other).first}))
    と一致します。

--- %(other)
    ((|other|)) で割った余りを返します。(({divmod(other).last}))
    と一致します。

--- divide?(other)
    ((|other|)) で割り切れるとき真を返します。
    (({divmod(other).last == zero?}))と一致します。

--- deg
    次数を返します。

    例:
      P = Algebra::Polynomial(Integer, "x")
      x = P.var
      (5*x**3 + 2*x + 1).deg #=> 3

--- lc
    先頭係数(leading coeffcient)を返します。

    例:
      (5*x**3 + 2*x + 1).lc #=> 5

--- lm
    先頭単項式(leading monomial)を返します。

    例:
      (5*x**3 + 2*x + 1).lm #=> x**3

--- lt
    先頭項(leading term)を返します。(({lc * lm}))と等しい値を持ちます。

    例:
      (5*x**3 + 2*x + 1).lt #=> 5*x**3

--- rt
    残余項(rest term)を返します。(({self - lt}))と等しい値を持ちます。

    例:
      (5*x**3 + 2*x + 1).rt #=> 2*x + 1

--- monic
    最高次係数を1に直した式を返します。(({self / lc})) と同じ値を持
    ちます。

--- cont
    係因数(content(全ての係数の最大公約数)）を返します。

--- pp
    原始的部分(primitive part)を返します。(({self / cont}))と
    同じ値を持ちます。

--- to_s
    文字列表現を得ます。表示形式を変えるには ((|display_type|)) を用います。
    ((|display_type|)) に与えられる値は ((|:norm|))(デフォルト), ((|:code|))
    です。

    例:
      P = Algebra::Polynomial(Integer, "x")
      x = P.var
      p 5*x**3 + 2*x + 1 #=>5x^3 + 2x + 1
      P.display_type = :code
      p 5*x**3 + 2*x + 1 #=> 5*x**3 + 2*x + 1

--- derivate
    微分した値を返します。

    例:
      (5*x**3 + 2*x + 1).derivate #=> 15*x**2 + 2

--- sylvester_matrix(other)
    ((|other|)) とのシルベスター行列を返します。

--- resultant(other)
    ((|other|)) との集結式返します。予め

--- project(ring[, obj]){|c, n| ... }
    各単項式について、
    次数を ((|n|)) に、係数 ((|c|)) に代入し ... を評価したものを
    その単項式の値に置き換え、((|ring|)) 上で和を取った値を
    返します。((|obj|)) が省略されると (({ring.var})) が用いら
    れます。

    例:
      require "polynomial"
      require "rational"
      P = Algebra::Polynomial(Integer, "x")
      PQ = Algebra::Polynomial(Rational, "y")
      x = P.var
      f = 5*x**3 + 2*x + 1
      p f.convert_to(PQ) #=> 5y^3 + 2y + 1
      p f.project(PQ) {|c, n| Rational(c) / (n + 1)} #=> 5/4y^3 + y + 1

--- evaluate(obj)
    主変数に ((|obj|)) を代入した値を返します。
    (({ project(ground, obj){|c, n| c} })) の値と一致します。

    例:
      require "polynomial"
      P = Algebra::Polynomial(Integer, "x")
      x = P.var
      f = x**3 - 3*x**2 + 1
      p f.evaluate(-1)    #=> -3 (in Integer)
      p f.evaluate(x + 1) #=> x^3 - 3x - 1 (in P)

--- call(obj)
    ((<evaluate>))と同じです。

--- sub(var, value)
    変数 ((|var|)) に ((|value|)) を代入した値を返します。

    例:
      require "polynomial"
      P = Algebra::Polynomial(Integer, "x", "y", "z")
      x, y, z = P.vars
      f = (x - y)*(y - z - 1)
      p f.sub(y, z+1)    #=> 0

--- convert_to(ring)
    各項を((|ring|))上で評価します。(({ project(ring){|c, n| c} }))の
    値と一致します。

= Algebra::PolynomialFactorization
((*(因数分解モジュール)*))

因数分解をするためのモジュールです。

== ファイル名:
((|polynomial-factor.rb|))

== メソッド:

--- sqfree
    無平方化します。

--- sqfree?
    無平方なら真を返します。

--- irreducible?
    既約なら真を返します。

--- factorize
    因数分解します。

    因数分解可能な係数環は
    * Integer
    * Rational
    * 素体
    * 代数体（Rational 上の有限次拡大）
    です。

= Algebra::SplittingField
((*(分解体モジュール)*))

多項式の最小分解体を求めるためのモジュール

== ファイル名:
* ((|splitting-field.rb|))

== メソッド:

--- decompose([fac0])
    自身の最小分解体を ((|field|))、拡大に要した既約多項式
    の配列を ((|def_polys|))、最小分解体上で1次式の積に因数分解し
    たものを ((|facts|))、多項式の根の配列を ((|roots|))、
    ((|roots|)) を基礎体に添加した元が前に来るように並べ替えた
    の配列を ((|proots|)) として、

      [field, def_polys, facts, roots, proots]

    を返します。基礎体上の因数分解 ((|fac0|)) を添えると高速化に役立ちます。
    （((|facts|)) の要素と ((|fact0|)) は ((|Algebra::Factors|)) オブジェクト
    、((|field|)) は
    ((<AlgebraicExtensionField|algebraic-extension-field.html>))
    オブジェクトです。ただし、自身が一次因子に分解されるときは
    ((<groud>)) そのものを返します。

    例:
      require "algebra"
      PQ = Polynomial(Rational, "x")
      x = PQ.var
      f = x**5 - x**4 + 2*x - 2
      field, def_polys, facts, roots, proots = f.decompose
      p def_polys #=> [a^4 + 2, b^2 + a^2]
      p facts    #=> (x - 1)(x - a)(x + a)(x - b)(x + b)
      p roots    #=> [1, a, -a, b, -b]
      p proots   #=> [a, b, 1, -a, -b]
      fp = Polynomial(field, "x")
      x = fp.var
      facts1 = Factors.new(facts.collect{|g, n| [g.call(x), n]})
      p facts1.pi == f.convert_to(fp) #=> true

--- splitting_field([fac0]))
    自身の最小分解体の情報を返します。返り値の各フィールドの値は以下
    の通りです。poly_exps 以外は ((<decompose>)) の以下のものに相当します。

    poly, field, roots, proots, def_polys

    ただし、((|roots|))、((|proots|)) の各要素は ((|field|)) の
    要素として変換されています。

    例:
      require "algebra"
      PQ = Polynomial(Rational, "x")
      x = PQ.var
      f = x**5 - x**4 + 2*x - 2
      sf = f.splitting_field
      p sf.roots     #=> [1, a, -a, b, -b]
      p sf.proots     #=> [a, b, 1, -a, -b]
      p sf.def_polys #=> [a^4 + 2, b^2 + a^2]

= Algebra::Galois
((*(ガロア群)*))

多項式のガロア群を求めるためのモジュール

== ファイル名:
* ((|galois-group.rb|))

== インクルードしているモジュール:
* なし

== 関連するメソッド:

--- GaloisGroup.galois_group(poly)
    ((<galois_group>)) と同じ

== モジュールメソッド:
* なし

== メソッド:

--- galois_group
    多項式のガロア群を返します。群は各元が
    ((<PermutationGroup|permutation-group.html>)) である
    ((<FiniteGroup|finite-group.html>)) オブジェクトとして表現されます。

    例:
      require "rational"
      require "polynomial"

      P = Algebra.Polynomial(Rational, "x")
      x = P.var
      p( (x**3 - 3*x + 1).galois_group.to_a )
      #=>[[0, 1, 2], [1, 2, 0], [2, 0, 1]]

      (x**3 - x + 1).galois_group.each do |g|
        p g
      end
      #=> [0, 1, 2]
      #   [1, 0, 2]
      #   [2, 0, 1]
      #   [0, 2, 1]
      #   [1, 2, 0]
      #   [2, 1, 0]

=end


#' Range of Distribution
#'
#' Range returns a 2 index vector with the 0th index
#' containing the minimum value, and the 1st index containing the maximum value
#' for a given distribution.
#'
#' @param distribution Single distribution to compute range from.
#' @param ... Not used; vestige of the `base::range()` S3 generic.
#' @details If there are no methods for the distribution's class,
#' the range is calculated
#' using `eval_quantile()` at 0 and at 1.
#' @examples
#' a <- dst_gpd(0, 1, 0.5)
#' b <- dst_unif(0, 1)
#' c <- dst_norm(3, 4)
#' range(a)
#' range(b)
#' range(c)
#' @rdname range
#' @export
range.dst <- function(distribution, ...) {
  eval_quantile(distribution, at = 0:1)
}


#=============================================================================
#Lecture 2 FISH554: ggplot types of plots, using themes
#Trevor A. Branch tbranch@uw.edu January 2021
#data files needed:
#    WCcatches.csv: catches of west coast fish species over time
#    BlueLengths.csv: latitude and length of sample of
#           mature female blue whales in Southern Hemisphere
#=============================================================================

#libraries required here
library(tidyverse)  #includes packages readr and ggplot2
library(hexbin)
library(here)

#data files used: WCcatches.csv

#get some data to look at
WC <- read_csv(file=here("Documents","data","beautiful_graphics","WCcatches.csv"))   #read_csv creates tibble
print(WC)
#side note that these data are in wide format not long format

#======simple plots with year vs. catches
#area plots
ggplot(data=WC, aes(x=Year, y=Sablefish)) +
    geom_area()

#bar plots
ggplot(data=WC, aes(x=Year, y=Sablefish)) +
    geom_col()

#line plots
ggplot(data=WC, aes(x=Year, y=Sablefish)) +
    geom_line()

#point plots
ggplot(data=WC, aes(x=Year, y=Sablefish)) +
    geom_point()

#step plots (skyscraper plots)
ggplot(data=WC, aes(x=Year, y=Sablefish)) +
    geom_step()

#to plot one of the columns with spaces in the title, use the `` symbol
#(top left on keyboards)
ggplot(data=WC, aes(x=Year, y=`Bocaccio rockfish`)) +
    geom_step()

#=======changing the order of data=======
#reordering ensures that both sets of data are reordered
WC <- read_csv(file="WCcatches.csv")   #read_csv is in readr, creates tibble
WC1990s <- filter(WC, Year >= 1990)    #get just data since 1990
ggplot(data=WC1990s, aes(x=Year, y=Sablefish)) +
    geom_col()

#order by sablefish catches
ggplot(data=WC1990s, aes(x=reorder(Year, Sablefish), y=Sablefish)) +
    geom_col(width=0.9)

#order by reverse year
ggplot(data=WC1990s, aes(x=reorder(Year, rev(Year)), y=Sablefish)) +
    geom_col()

#==========Frequencies and histograms=======================================
#create 10000 random numbers from a normal distribution
#tinker with the mean and sd values to see how the plots change
#change data into tibble (data frame) format
normdata <- as_tibble(x=rnorm(n=10000, mean=55, sd=10))
print(normdata) #note that as.tibble() automatically called the data "value"

#histogram
ggplot(data=normdata, aes(x=value)) +
    geom_histogram()
ggplot(data=normdata, aes(x=value)) +
    geom_histogram(binwidth=1)  #change default binwidth
ggplot(data=normdata, aes(x=value)) +
    geom_histogram(binwidth=5)

#polygon of frequency
ggplot(data=normdata, aes(x=value)) +
    geom_freqpoly(binwidth=1)

#areaplot with bins
ggplot(data=normdata, aes(x=value)) +
    geom_area(stat="bin", binwidth=1)

#smoothed curve fitted to frequencies
ggplot(data=normdata, aes(x=value)) +
    geom_density()

ggplot(data=normdata, aes(x=value)) +
    geom_density(kernel="gaussian")

#bar plot of discrete values (round to whole numbers)
normintegers <- round(normdata,0) #round values to whole numbers
print(normintegers)
ggplot(data=normintegers, aes(x=value)) +
    geom_bar()

#============points, jitter, heatmap
#Blue whale catches (year, latitude, length from 30-80E, 25S to 80S, 1950-1973)
library(tidyverse)  #includes packages readr and ggplot2
bluedata <- read_csv(file=here("Documents","data","beautiful_graphics","BlueLengths.csv"))
print(bluedata)

#point plots: do you see any interesting patterns?
ggplot(data=bluedata, aes(x=Lat, y=LenFt)) +
    geom_point()

#jitter plot
#for overlapping points, add a little bit of "jitter", also helps with
#rounded data, and here many latitudes; lengths rounded to whole numbers
ggplot(data=bluedata, aes(x=Lat, y=LenFt)) +
    geom_jitter(width=0.2, height=0.2)

ggplot(data=bluedata, aes(x=Lat, y=LenFt)) +
    geom_jitter(width=0.5, height=0.5)  #greater jitter amount

#add a smooth fitted line using locally estimated smoothers
ggplot(data=bluedata, aes(x=Lat, y=LenFt)) +
    geom_jitter(width=0.5, height=0.5) +
    geom_smooth(method="loess", span=0.5)  #add a local smoother

#heatmap / 2D bin
ggplot(data=bluedata, aes(x=Lat, y=LenFt)) +
    geom_bin2d()
ggplot(data=bluedata, aes(x=Lat, y=LenFt)) +
    geom_bin2d(binwidth=c(1,1)) #with much smaller bins

#hex plot
library(hexbin)
ggplot(data=bluedata, aes(x=Lat, y=LenFt)) +
    geom_hex(binwidth=c(1,1))

#contour plot of two normal distributions
twonorms <- as_tibble(cbind(x=rnorm(10000), y=rnorm(10000)))
ggplot(data=twonorms, aes(x=x, y=y)) +
    geom_density2d()

#===============Making prettier plots: barplots=================================
library(tidyverse)
WC <- read_csv(file="WCcatches.csv")   #read_csv is in readr, creates tibble
ggplot(data=WC, aes(x=Year, y=Sablefish)) +
    geom_col() +
    xlab("Year") +   #add appropriate labels for axes
    ylab("Sablefish catches (metric tons)") +
    theme_classic()  #change the default theme of the plot

ggplot(data=WC, aes(x=Year, y=Sablefish)) +
    geom_col() +
    xlab("Year") +
    ylab("Sablefish catches (metric tons)") +
    theme_minimal() +
    scale_x_continuous(expand = c(0, 0)) + #no expansion below or above min/max
    scale_y_continuous(expand = c(0, 0))  #no expansion below or above min/max

#======coordinate systems: flip, equal, log-transform etc.==========
LW <- read_csv(file=here("Documents","data","beautiful_graphics","LengthWeight.csv"))
print(LW)
ggplot(data=LW, aes(x=LengthCM, y=WeightKG)) +
    theme_classic() +
    geom_point()

#x and y axes have equal sizes between units
#since coord_fixed does not make sense for these data
#I first multiplied weight by 20
ggplot(data=LW, aes(x=LengthCM, y=WeightKG*20)) +
    theme_classic() +
    geom_point() + coord_fixed()

#flip axes, so x data vertical and y data horizontal
ggplot(data=LW, aes(x=LengthCM, y=WeightKG)) + theme_classic() +
    geom_point() + coord_flip()

#log-x and log-y (natural logarithm)
ggplot(data=LW, aes(x=LengthCM, y=WeightKG)) + theme_classic() +
    geom_point() +
    coord_trans(x="log", y="log")

#===barplots with an error bar=======
WC <- read_csv(file="WCcatches.csv")
ggplot(data=WC, aes(x=Year, y=Sablefish)) +
    geom_col() + xlab("Year") +
    ylab("Sablefish catches (metric tons)") +
    theme_minimal() +
    #add error bar (20% below, 20% above)
    geom_errorbar(aes(ymax=Sablefish*1.2, ymin=Sablefish*0.8)) +
    scale_x_continuous(expand = c(0, 0))+ #no expansion below or above min/max
    scale_y_continuous(expand = c(0, 0))  #no expansion below or above min/max

ggplot(data=WC, aes(x=Year, y=Sablefish)) +
    geom_col() + xlab("Year") + ylab("Sablefish catches (metric tons)") +
    theme_minimal() +
    #only the upper error bar, arbitrarily 20% higher
    geom_errorbar(aes(ymax=Sablefish*1.2, ymin=Sablefish)) +
    scale_x_continuous(expand = c(0, 0))+ #no expansion below or above min/max
    scale_y_continuous(expand = c(0, 0)) #no expansion below or above min/max

#====points with an error line around them (no error bar)=======================
#geom_pointrange() is more elegant than bar plots for many
#uses, and less data ink than a formal error
#bar that has horizontal lines above and below.
ggplot(data=WC, aes(x=Year, y=Sablefish)) +
    geom_pointrange(aes(ymax=Sablefish*1.2, ymin=Sablefish*0.8)) +
    xlab("Year") + ylab("Sablefish catches (metric tons)") +
    theme_minimal() +
    scale_x_continuous(expand = c(0, 0)) +
    scale_y_continuous(expand = c(0, 0)) #no expansion below or above min/max

ggplot(data=WC, aes(x=Year, y=Sablefish)) +
    geom_pointrange(aes(ymax=Sablefish*1.2, ymin=Sablefish*0.8)) +
    xlab("Year") + ylab("Sablefish catches (metric tons)") +
    theme_minimal() +
    scale_x_continuous(expand = c(0.01, 0.01))+ #add 1% expansion for points
    scale_y_continuous(expand = c(0, 0)) +
    #how to set limits on the x axis or y axis (does not clip values outside lims)
    coord_cartesian(ylim=c(0,33000))
    #ylim(0,33000) + xlim(1950,2005)  #another way of setting limits

#=============adding a fitted trendline to a plot of points=====================
x <- sort(runif(20,1,10)) #create some random data
correl.data <- as_tibble(cbind(x = x,   #generate 20 values from a uniform between 1 and 10
                         y = x + rnorm(20)))         #add some normal random numbers to the x values
print(correl.data)
ggplot(data=correl.data, aes(x=x, y=y)) +
    geom_point() + theme_minimal() +
    geom_smooth(method="lm", level=0.95) #add a linear prediction 95% CI

#========point sizes, symbols, colors, transparency=====
#make the points bigger
correl.data <- as_tibble(cbind(x = x,   #generate 20 values from a uniform between 1 and 10
                               y = x + rnorm(20)))         #add some normal random numbers to the x values
ggplot(data=correl.data, aes(x=x, y=y)) +
    geom_point(size=1) + theme_minimal()
ggplot(data=correl.data, aes(x=x, y=y)) +
    geom_point(size=3) + theme_minimal()
ggplot(data=correl.data, aes(x=x, y=y)) +
    geom_point(size=1:20) + theme_minimal()  #different size for each point

#different shapes
ggplot(data=correl.data, aes(x=x, y=y)) +
    geom_point(shape=1:20, size=5) + theme_minimal()

#can specify anything as the shape, but "." is one pixel
#here is an enormous dataset
twonorms <- as_tibble(cbind(x=rnorm(100000), y=rnorm(100000)))

#might be slow to plot since 100,000 data points
ggplot(data=twonorms, aes(x=x, y=y)) +
    geom_point(shape=".") + theme_minimal()

#different colors (more on colors in the color lecture)
ggplot(data=correl.data, aes(x=x, y=y)) +
    geom_point(color="red", size=5) + theme_minimal()
ggplot(data=correl.data, aes(x=x, y=y)) +
    geom_point(color=c(rep("red",10), rep("blue",10)), size=5) +
    theme_minimal()

#rainbow() is a built-in palette that returns a suits of colors
#later I will explain why rainbow palettes are very bad...
ggplot(data=correl.data, aes(x=x, y=y)) +
    geom_point(color=rainbow(20), size=5) +
    theme_minimal()

#shapes 21:25 have a fill color but the others do not
ggplot(data=correl.data, aes(x=x, y=y)) +
    geom_point(color="black", size=5, fill="green", shape=21) +
    theme_minimal()
ggplot(data=correl.data, aes(x=x, y=y)) +
    geom_point(color="black", size=5, fill="green", shape=19) +
    theme_minimal()

#transparency in color, applies to both outline and fill
#seq = give 20 values between 0 (transparent) and 1 (opaque)
ggplot(data=correl.data, aes(x=x, y=y)) +
    geom_point(color="black", size=5, fill="green", shape=21,
               alpha=seq(0,1,length.out=20)) +
    theme_minimal()

#========line width, type===================================
#different line types: 1=solid, 2=dashed, 3=dot, 4=dot-dash
#generally looks terrible to distinguish between lines with
#different line types, so this should be avoided
WC <- read_csv(file="WCcatches.csv")
ggplot(data=WC, aes(x=Year, y=Sablefish)) + theme_minimal() +
    geom_line(linetype=1) +
    xlab("Year") + ylab("Sablefish catches (metric tons)")
ggplot(data=WC, aes(x=Year, y=Sablefish)) + theme_minimal() +
    geom_line(linetype=2) +
    xlab("Year") + ylab("Sablefish catches (metric tons)")
ggplot(data=WC, aes(x=Year, y=Sablefish)) + theme_minimal() +
    geom_line(linetype=3) +
    xlab("Year") + ylab("Sablefish catches (metric tons)")
ggplot(data=WC, aes(x=Year, y=Sablefish)) + theme_minimal() +
    geom_line(linetype=4) +
    xlab("Year") + ylab("Sablefish catches (metric tons)")

#line widths
ggplot(data=WC, aes(x=Year, y=Sablefish)) + theme_minimal() +
    geom_line(linetype=1, size=3) +
    xlab("Year") + ylab("Sablefish catches (metric tons)")
ggplot(data=WC, aes(x=Year, y=Sablefish)) + theme_minimal() +
    geom_line(linetype=1, size=1:56/14) +
    xlab("Year") + ylab("Sablefish catches (metric tons)")

#========adding vertical/horizontal lines
ggplot(data=WC, aes(x=Year, y=Sablefish)) + theme_minimal() +
    geom_line(linetype=1, size=1:56/14) +
    xlab("Year") + ylab("Sablefish catches (metric tons)") +
    geom_hline(yintercept=10000, linetype="dashed",
               color = "gray50", size=1)
ggplot(data=WC, aes(x=Year, y=Sablefish)) +
    theme_minimal() +
    geom_line(linetype=1, size=1:56/14) +
    xlab("Year") + ylab("Sablefish catches (metric tons)") +
    geom_vline(xintercept=1974, linetype="dashed",
               color = "gray50", size=1)

#there is also geom_ribbon, geom_polygon, geom_segment,
#geom_rect for other ways of adding objects to plots

#========EXERCISES===============================================
#**DO EXERCISE 1: accident data from xkcd cartoon
#Try to get ordered data with horizontal barplots
acc <- read_csv("Accidents.csv")     #read in data

#**DO EXERCISE 2: Old Faithful eruptions at Yellowstone N.P.
#explore different plotting types to see which represents the data the best
OldF <- read_csv("OldFaithfulDuration.csv")

#**CHALLENGE EXERCISE 3: university salaries
#how to represent data that goes outside the bounds of the plot?
sal <- read.csv("UnivSalaries.csv")


source('lib/libraries.r', encoding = 'UTF-8')

bruto_slovenija1$Leto <- as.character(bruto_slovenija1$Leto)
bruto_slovenija1$BDP <- as.character(bruto_slovenija1$BDP)

bruto_slovenija1 <- bruto_slovenija1 %>% mutate(Leto = parse_integer(Leto), BDP = parse_number(BDP))
prileganje <- lm(BDP ~ Leto, data = bruto_slovenija1)
predict(prileganje, data.frame(Leto=seq(2017,2020,1)))

graf_napoved <- ggplot(bruto_slovenija1, aes(x=Leto, y=BDP)) + geom_point() +
  geom_smooth(method='lm', formula=y ~ poly(x,2,raw=TRUE), fullrange=TRUE, color='green') + scale_x_continuous('Leto', breaks = seq(2007, 2020, 1), limits = c(2007,2020))


#' Compute \code{y*log(y)}
ylogy = function(y) {
    return( ifelse(y==0, 0, y*log(y)) )
}


library(data.table)
library(dplyr)
library(ggplot2)
library(covid19AgeModel)

args = list()
args$indir = "~/git/R0t/covid19AgeModel/inst"

args$file_age_ifr <- file.path(args$indir,'data','ifr-by-age-prior_Levin_raw_200904.csv')

#
# Read and clean Levin et al. Supplementary material
ifr_lognormal = as.data.table(read.csv( args$file_age_ifr ))
tmp1 = select(ifr_lognormal, c("Age", "IFR", "Lower.Bound", "Upper.Bound"))
tmp1 = subset(tmp1, !Age %in% c("0-34", "95+"))
tmp1[, log_ifr_mean := log(IFR/100) ]
tmp1[, log_ifr_cl := log(Lower.Bound/100) ]
tmp1[, log_ifr_cu := log(Upper.Bound/100) ]
tmp1[, Age := as.numeric(Age)]
setnames(tmp1, "Age", "age")
tmp1 = select(tmp1, -c("IFR", "Lower.Bound", "Upper.Bound"))

#
# extrapolate straigh line
x = tmp1$age
b_M = (tmp1$log_ifr_mean[2] - tmp1$log_ifr_mean[1]) / (x[2] - x[1])
a_M = (x[2]*tmp1$log_ifr_mean[1] - x[1]*tmp1$log_ifr_mean[2]) / (x[2] - x[1])
b_CL = (tmp1$log_ifr_cl[2] - tmp1$log_ifr_cl[1]) / (x[2] - x[1])
a_CL = (x[2]*tmp1$log_ifr_cl[1] - x[1]*tmp1$log_ifr_cl[2]) / (x[2] - x[1])
b_CU = (tmp1$log_ifr_cu[2] - tmp1$log_ifr_cu[1]) / (x[2] - x[1])
a_CU = (x[2]*tmp1$log_ifr_cu[1] - x[1]*tmp1$log_ifr_cu[2]) / (x[2] - x[1])
age_missing = 0:34
tmp = data.table(age = age_missing,
                 log_ifr_mean = a_M + b_M*age_missing,
                 log_ifr_cl = a_CL + b_CL*age_missing,
                 log_ifr_cu = a_CU + b_CU*age_missing)

tmp = rbind( tmp, tmp1 )

#
# plot
if(0){
  ggplot(tmp, aes(x = age)) +
    geom_line(aes(y = log_ifr_mean)) +
    geom_ribbon(aes(ymin = log_ifr_cl, ymax = log_ifr_cu), alpha = 0.5)
}

#
# add raw scale
tmp[, ifr_mean := exp(log_ifr_mean)]
tmp[, ifr_cl := exp(log_ifr_cl)]
tmp[, ifr_cu := exp(log_ifr_cu)]

#
# Aggregate by 5 years age band
GFNAME_us_population = file.path(args$indir,"data","us_population_withnyc.rds")
ifr.by.age = as.data.table(read_ifr_data_by_age(path_to_file_pop_us = GFNAME_us_population, ifr.by.age = tmp, max_age = 95))

#
# Find hyperparameters log-normal distribution
library(lognorm)
ifr.by.age = ifr.by.age[, list(ln_mu = getParmsLognormForMeanAndUpper(mean = ifr_mean, quant = ifr_cu, sigmaFac=2)[1],
                                ln_sd = getParmsLognormForMeanAndUpper(mean = ifr_mean, quant = ifr_cu, sigmaFac=2)[2],
                                ifr_mean = ifr_mean,
                                ifr_cl = ifr_cl,
                                ifr_cu = ifr_cu), by = c("age")]
#
# Find hyperparameters beta distribution
library("prevalence")
ifr.by.age[, ifr_beta_alpha := betaExpert(ifr_mean, ifr_cl, ifr_cu, p = 0.95, method = "mean")$alpha, by = c("age")]
ifr.by.age[, ifr_beta_beta := betaExpert(ifr_mean, ifr_cl, ifr_cu, p = 0.95, method = "mean")$beta, by = c("age")]

#
# clean
setnames(ifr.by.age, "age", "age_cat")
ifr.by.age$age_cat_label = c(paste0(seq(0, 80, 5), "-", seq(4,84,5)), "85+")

#
# save
write.csv(ifr.by.age, file = file.path(args$indir, "data", 'ifr-by-age-prior_Levin_200904.csv'), row.names = F)


#-------------------------------------------------------------------
# vtfn -- Generate spectrum of vocal tract response given formant
#         frequency, amplitude, and bandwidth.
#
# Args:
#  pars -- A vector of named parameters for 8 formants. Each
#          parameter has a name such as f[1-8][fba] to specify
#          formant number (1-8) and parameter (f(requency),
#          b(andwidth), or a(mplitude)). All frequencies and
#          bandwidths specified in Hertz, and amplitudes in dB.
#
#  np   -- The number of points of spectrum values to cover the
#          Nyquist range from 0 - fs/2. This is deceptive because,
#          to be consistent with FFT concentions, there will really
#          be an np+1 point spectrum returned with the first value
#          corresponding to DC and the last to the Nyquist frequency.
#
#  fs   -- Sampling frequency in Hz.
#
# Notes: This is the "parallel formant" version with each formant
#        curve calculated independently and added to the others.
#        Each formant is also multiplied by an amplitude factor
#        that is passed as a quantity in dB via the pars vector.
#        Additionally, this function called the underlying formant
#        function with scaled=TRUE so that every formant response
#        curve is generated with a theoretical peak amplitude of 1.0.
#
# 1/10/20 -- htb
#-------------------------------------------------------------------

vtfn <- function(pars, np=512, fs=16000) {
  maxf <- fs/2
  a1s <- 10^(pars['f1a']/20)
  a2s <- 10^(pars['f2a']/20)
  a3s <- 10^(pars['f3a']/20)
  a4s <- 10^(pars['f4a']/20)
  a5s <- 10^(pars['f5a']/20)
  a6s <- 10^(pars['f6a']/20)
  a7s <- 10^(pars['f7a']/20)
  a8s <- 10^(pars['f8a']/20)

  f1 <- formant(pars['f1f'], pars['f1b'], np, maxf, scale=F)
  f2 <- formant(pars['f2f'], pars['f2b'], np, maxf, scale=F)
  f3 <- formant(pars['f3f'], pars['f3b'], np, maxf, scale=F)
  f4 <- formant(pars['f4f'], pars['f4b'], np, maxf, scale=F)
  f5 <- formant(pars['f5f'], pars['f5b'], np, maxf, scale=F)
  f6 <- formant(pars['f6f'], pars['f6b'], np, maxf, scale=F)
  f7 <- formant(pars['f7f'], pars['f7b'], np, maxf, scale=F)
  f8 <- formant(pars['f8f'], pars['f8b'], np, maxf, scale=F)

  s <- a1s*f1 + a2s*f2 + a3s*f3 + a4s*f4 + a5s*f5 +
    a6s*f6 + a7s*f7 + a8s*f8
  s
}


# take radius from user

a <- readline(prompt="Enter the radius:")
r <- as.double(a)

# compute area and store in a variable
area <- pi * r ^ 2

# print area
print(area)


setwd("C:\\Users\\lenovo\\Desktop\\Rdatamining")
getwd()
dir()
data(Titanic)
str(Titanic)
Titanic
# read AR data converted from titanic data from website http://www.cs.toronto.edu/~delve/
#data/titanic/desc.html
titan <- read.table("./dataset.data", header=F)
titan
names(titan) <- c("Class", "Sex", "Age", "Survived")
#install.packages("arules")
library(arules)
# find association rules with default settings
#supp=0.1, ; 2) conf=0.8, 3) maxlen=10,
rules.all <- apriori(titanic.raw)
quality(rules.all) <- round(quality(rules.all), digits=3)
rules.all
inspect(rules.all)
#rules with rhs containing "Survived" only
#restricted rules
rules <- apriori(titanic.raw, control = list(verbose=F), parameter = list(minlen=2, supp=0.005, conf=0.8),appearance = list(rhs=c("Survived=No", "Survived=Yes"),default="lhs"))
quality(rules) <- round(quality(rules), digits=2)
rules.sorted <- sort(rules, by="lift")
inspect(rules.sorted)

#restricting LHS
rules <- apriori(titanic.raw, control = list(verbose=F),parameter = list(minlen=3, supp=0.002, conf=0.7),appearance = list(rhs=c("Survived=Yes"),lhs=c("Class=1st", "Class=2nd", "Class=3rd","Age=Child", "Age=Adult"),default="none"))
quality(rules) <- round(quality(rules), digits=4)
rules.sorted <- sort(rules, by="lift")
inspect(rules.sorted)

#plotting AR
#install.packages("arulesViz")
library(arulesViz)
plot(rules.all)
plot(rules.all, method="grouped")

#another dataset market basket
data(Groceries)
inspect(Groceries[1:5])  #to see first 5 transactions

# Create an item frequency plot for the top 10 items
itemFrequencyPlot(Groceries,topN=10,type="absolute")
# Get the rules
rules <- apriori(Groceries, parameter = list(supp = 0.001, conf = 0.8))

# Show the top 5 rules, but only 2 digits
options(digits=2)
inspect(rules[1:5])
summary(rules)  #summary statistics


# SVR

# Libraries
library(ggplot2)
library(e1071)

# Importing dataset
dataset = read.csv('Position_Salaries.csv')
dataset = dataset[2:3]

# Fitting The SVR to the dataset
regressor = svm(formula = Salary ~ .,
                data = dataset,
                type = 'eps-regression')

y_pred = predict(regressor, data.frame(Level = 6.5))

# Visualising the Linear Regression Results
ggplot() +
  geom_point(aes(x = dataset$Level, y = dataset$Salary),
             colour = 'red') +
  geom_line(aes(x = dataset$Level, y = predict(regressor, newdata = dataset)),
            colour = 'blue') +
  ggtitle('Truth or Bluff (SVR)') +
  xlab('Level') +
  ylab('Salary')


QSAR_ridge_regression <- function (X, Y, K) {

     # Ridge regression with parcor package
     # Date: 8-4-2014
     # Author: Sheikh M. Rahman
     # require parcor, ggplot2 packages
     # X variables, Y response, k - fold validation
     ridgeFit <- ridge.cv(X, Y, k = K, scale = FALSE); # it will find the optimum lambda by 10-fold validation

     coeff_ridge <- matrix(ridgeFit$coefficients,nrow = 1)

     # fitted data
     yFit <- X %*% t(coeff_ridge) # matrix multiplication
     yFit <- yFit + ridgeFit$intercept # add intercept

     residualY <- yFit - Y # residual
     sumResidual <- sum(residualY);

     SquaredError <- (yFit - Y)^2
     SumSquareError <- sum(SquaredError);
     #############################################
     # R- square calculation
     # DOF: Model- p (p, no. of explanatory variables, not includes the intercept)
     #  	Error- n-p-1 (n, no. of samples)
     #############################################
     SumSquareModel <- sum((yFit - mean(Y))^2)
     SumSquareTotal <- sum((Y - mean(Y))^2)

     Rsquared <- SumSquareModel/SumSquareTotal;

     return (list(ridgeFit = ridgeFit, yFit = yFit, residualY = residualY,
                  sumResidual = sumResidual, SquaredError = SquaredError,
                  SumSquareError = SumSquareError, Rsquared = Rsquared, X = X, Yobs = Y))

}

QSAR_lasso_regression <- function (X, Y, K) {
     lassoFit <- adalasso(X,Y, k = K, both = FALSE); # it will find the optimum lambda by k-fold validation

     coeff_lasso <- matrix(lassoFit$coefficients.lasso,nrow = 1)

     # fitted data
     yFit <- X %*% t(coeff_lasso) # matrix multiplication
     yFit <- yFit + lassoFit$intercept.lasso # add intercept
     yFit[yFit<0] <- 0 # to change the negative value to 0
     residualY <- yFit - Y # residual
     sumResidual <- sum(residualY);

     SquaredError <- (yFit - Y)^2
     SumSquareError <- sum(SquaredError);

     #############################################
     # R- square calculation
     # DOF: Model- p (p, no. of explanatory variables, not includes the intercept)
     #       Error- n-p-1 (n, no. of samples)
     #############################################
     SumSquareModel <- sum((yFit - mean(Y))^2)
     SumSquareTotal <- sum((Y - mean(Y))^2)

     Rsquared <- SumSquareModel/SumSquareTotal;

     return (list(lassoFit = lassoFit, yFit = yFit, residualY = residualY,
                  sumResidual = sumResidual, SquaredError = SquaredError,
                  SumSquareError = SumSquareError, Rsquared = Rsquared, X = X, Yobs = Y))

}

plotPanelFigures <- function (Y, regMdl, axsLabel,subHdr) {
yTest_obs <- Y
#coeff <- matrix(regMdl$lassoFit$coefficients.lasso, nrow = 1)
#intercept <- regMdl$lassoFit$intercept.lasso
#yTest <- regMdl$X %*% t( coeff ) # matrix multiplication
yTest <- regMdl$yFit
#yTest[yTest<0] <- 1
#dat <- data.frame(xvar = log(yTest_obs), yvar = log(yTest))
dat <- data.frame(xvar = (yTest_obs), yvar = (yTest))
p <- ggplot(dat, aes(x=xvar, y=yvar)) + labs(title=axsLabel,subtitle=subHdr)+
  geom_point(colour="blue", size = 2.0, shape = 21, fill='orange') +
  theme_bw()  + coord_cartesian(xlim = c(0, 8000), ylim = c(0, 8000)) + #coord_cartesian(xlim = c(0, 10), ylim = c(0, 10)) +
  geom_abline(intercept = 0, slope = 1,'linetype' = 'dashed',color = 'black','size' = 0.5) +
  theme (axis.title = element_text(size=21), axis.text=element_text(colour="black",size=10)) +
  labs(x="", y="") +  theme(plot.title = element_text(size=12, hjust=0.5, face="bold", vjust=-1)) +
  theme(plot.subtitle = element_text(size=9, hjust=0.5, vjust=1)) +
  #annotate("text", x=1.25, y=9.5, label= paste("R^2 == ", round(regMdl$Rsquared,2)), parse=TRUE, size = 4,family="Arial", fontface = 2)
  annotate("text", x=1000, y=7500, label= paste("R^2 == ", round(regMdl$Rsquared,2)), parse=TRUE, size = 4,family="Arial", fontface = "bold")

#  labs(x=paste("Observed", axsLabel), y=paste("Predicted", axsLabel))

return(p)
}


library(tidyverse)
library(reshape2)
install.packages('caret')
install.packages('DMwR')
library(caret)
library(xgboost)
library(Matrix)
library(tictoc)
library(PRROC)
library(DMwR)
library(gridExtra)

theme_set(theme_light())

data <- read.csv("creditcard.csv")

data$Class <- factor(ifelse(data$Class == 0, "zero", "one"))

sapply(data, function(x) sum(is.na(x)))

data$time_of_day <- data$Time %%(24*3600)

summary(data$time_of_day)
data$Time<-NULL
ggplot(data, aes(x = time_of_day, fill = Class)) +
  geom_density(alpha = 0.5) +
  labs(title = "Time of Day",
       x = "Time of Day",
       y = "Density",
       col = "Class") +
  scale_fill_discrete(labels = c("Fraud", "Not Fraud"))

summary(data$Amount)
ggplot(data, aes(x = Amount, fill = Class)) +
  geom_density(alpha = 0.3) +
 scale_x_continuous(limits = c(0, 2000), breaks = seq(0, 1000, 200)) +
  labs(title = "Amount",
       x = "Amount",
       y = "Density",
       col = "Class") +
  scale_fill_discrete(labels = c("Fraud", "Not Fraud"))

data$logamount<-log(data$Amount+1)
ggplot(data, aes(x = logamount, fill = Class)) +
  geom_density(alpha = 0.3) +
 scale_x_continuous(limits = c(0, 10), breaks = seq(0, 10, 1)) +
  labs(title = "Log Amount",
       x = "Log Amount",
       y = "Density",
       col = "Class") +
  scale_fill_discrete(labels = c("Fraud", "Not Fraud"))

data$Amount<-NULL

names(data)

par(mfrow=c(1,1))
for (i in 1:28){
print(ggplot(data, aes_string(x = paste0('V',i), fill = 'Class')) +
  geom_density(alpha = 0.3) +
  labs(title = paste('PCA feature: V',i),
       x = paste0('V',i),
       y = "Density",
       col = "Class") +
  scale_fill_discrete(labels = c("Fraud", "Not Fraud")))}

corr<-round(cor(data[,!(names(data) %in% c('Class'))]),2)
max(abs(corr)[upper.tri(corr)])
corr[29:30,]

features <- data[,!(names(data) %in% c('Class'))]

cbind(melt(apply(features, 2, min), value.name = "min"),
      melt(apply(features, 2, max), value.name = "max"))

rescaler <- function(x) {
  return((x - min(x)) / (max(x) - min(x)))
}

features_rescaled <- as.data.frame(apply(features, 2, rescaler))

cbind(melt(apply(features_rescaled, 2, min), value.name = "min_after_rescaling"),
      melt(apply(features_rescaled, 2, max), value.name = "max_after_rescaling"))

rescaleddata <- data.frame(cbind(features_rescaled,Class=data$Class))
str(rescaleddata)

set.seed(900)
library(caTools)
split <- sample.split(rescaleddata$Class, SplitRatio = 0.7)
train <-  subset(rescaleddata, split == TRUE)
test <- subset(rescaleddata, split == FALSE)

train_smote <- SMOTE(Class ~ ., data  = train,
                      perc.over = 500, k = 5, perc.under = 400)

table(train_smote$Class)
table(train$Class)

p1 <- ggplot(train, aes(x = logamount, y = time_of_day, col = Class)) +
  geom_point(alpha = 0.3) +
  facet_wrap(~ Class, labeller = labeller(Class = c('zero' = "Not Fraud", 'one' = "Fraud"))) +
  labs(title = "Before SMOTE",
       subtitle = "Training Data",
       col = "Class") +
  scale_x_continuous(limits = c(0, 1)) +
  scale_y_continuous(limits = c(0, 1)) +
  theme(legend.position = "none")

p2 <- ggplot(train_smote, aes(x = logamount, y = time_of_day, col = Class)) +
  geom_point(alpha = 0.3) +
  facet_wrap(~ Class, labeller = labeller(Class = c('zero' = "Not Fraud", 'one' = "Fraud"))) +
  labs(title = "After SMOTE",
       subtitle = "SMOTE sampling",
       col = "Class") +
  scale_x_continuous(limits = c(0, 1)) +
  scale_y_continuous(limits = c(0, 1)) +
  theme(legend.position = "none")
grid.arrange(p1, p2, nrow = 2)

xgb.data.train <- xgb.DMatrix(as.matrix(train[, colnames(train) != "Class"]),
                              label = ifelse(train$Class == 'zero', 0, 1))

xgb.data.train.smote <- xgb.DMatrix(as.matrix(train_smote[, colnames(train_smote) != "Class"]),
                                    label = ifelse(train_smote$Class == 'zero', 0, 1))

xgb.data.test <- xgb.DMatrix(as.matrix(test[, colnames(test) != "Class"]),
                             label = ifelse(test$Class == 'zero', 0, 1))

library(microbenchmark)
library(pROC)

xgb.bench.speed = microbenchmark(
    xgb.model.speed <- xgb.train(data = xgb.data.train,
                                 params = list(objective = "binary:logistic",
                                               eta = 0.1,
                                               max.depth = 3,
                                               min_child_weight = 100,
                                               subsample = 1,
                                               colsample_bytree = 1,
                                               nthread = 3,
                                               eval_metric = "auc"),
                                 watchlist = list(test = xgb.data.test),
                                 nrounds = 500,
                                 early_stopping_rounds = 40,
                                 print_every_n = 20), times = 5L)
print(xgb.bench.speed)
print(xgb.model.speed$bestScore)

xgb.bench.smote.speed = microbenchmark(
    xgb.smote.model.speed <- xgb.train(data = xgb.data.train.smote,
                                 params = list(objective = "binary:logistic",
                                               eta = 0.1,
                                               max.depth = 3,
                                               min_child_weight = 100,
                                               subsample = 1,
                                               colsample_bytree = 1,
                                               nthread = 3,
                                               eval_metric = "auc"),
                                 watchlist = list(test = xgb.data.test),
                                 nrounds = 500,
                                 early_stopping_rounds = 40,
                                 print_every_n = 20), times = 5L)
print(xgb.bench.smote.speed)
print(xgb.smote.model.speed$bestScore)

pred.resp <- factor(ifelse(xgb.test >= 0.5, 'one', 'zero'))
confusionMatrix(pred.resp, test$Class, positive="one")

pred.resp.smote <- factor(ifelse(xgb.test.smote >= 0.5, 'one', 'zero'))
confusionMatrix(pred.resp.smote, test$Class, positive="one")


###
# rankZ function definition
rankZ <- function(x) {
  x <- rank(x, na.last = "keep") / (length(x) - sum(is.na(x)) + 1)
  return(qnorm(x))
}


# Likelihood and optimization of an AR(1) model with trend
# Rest is taken over from analysis v23

# Model ------------------------------------------------------------------------

set.seed(2020)

#' LogLikelihood of AR(1) model with drift and seasonality
#'
#' Box & Jenkins suggest using unconditional likelihood, but here I have taken
#' the approach of excluding p + q variables for ease.
#'
#' @param mu,sigma,phi scalars
#' @param betas vector of betas for xreg
#' @param xreg matrix of regressors similar to mu
#'
#' @keywords internal
logL <- function(x, mu, sigma, phi1, betas = NULL, xreg = NULL) {
  n <- length(x)
  M <- phi1*x[-n] + mu * (1 - phi1)
  if (!is.null(betas) || !is.null(xreg)) {
    reg <- xreg[-1,,drop=FALSE] - phi1*xreg[-n,,drop=FALSE]
    M <- M + reg %*% betas
  }
  squared <- (x[-1] - M)^2
  sum(-squared/(2*sigma^2)) - (n - 1)*log(sigma * sqrt(2*pi))
}

logL(rnorm(100), mu = 0, sigma = 1, phi1 = 5, betas = 2, xreg = matrix(c(rep(0, 4), 1:(100-4))))
logL(rnorm(100), mu = 0, sigma = 1, phi1 = 5)

logL.compile <- function(mu = NULL, sigma = NULL, phi1 = NULL, betas = list()) {

  stopifnot(length(betas) == 0 || !is.null(names(betas)))

  i <- 0

  fn.str <- sprintf(
    'function(par, x, xreg = NULL) {
      logL(x = x, mu = %s, sigma = %s, phi1 = %s, betas = %s, xreg = xreg)
    }'
    , if (is.null(mu)) sprintf('par[%i]', (i <- i + 1)) else mu
    , if (is.null(sigma)) sprintf('par[%i]', (i <- i + 1)) else sigma
    , if (is.null(phi1)) sprintf('par[%i]', (i <- i + 1)) else phi1
    , if (length(betas) > 0L)
      sprintf('c(%s)', paste(names(betas), '=', vapply(betas, function(v)
        if (is.null(v)) sprintf('par[%i]', (i <<- i + 1)) else as.character(v), ''), collapse = ', '))
      else 'NULL'
  )

  fn <- eval(parse(text = fn.str))
  environment(fn) <- globalenv()

  fn
}

(logL.fn <- logL.compile(phi1 = 0, betas = list('b1' = 1, 'b2' = NULL, 'b3' = 3)))
logL.fn(par = c(1,2,3), x = rnorm(100), xreg = matrix(rnorm(300), ncol = 3))
(logL.fn <- logL.compile(phi1 = 0))
logL.fn(par = c(1,2), x = rnorm(100))

sim <- function(n, mu, sigma, phi1, betas = NULL, xreg = NULL,
                init = mu, xt = NULL, a = rnorm(n, 0, sd = sigma)) {

  R <- rep(0, n)
  if (!is.null(betas) || !is.null(xreg)) {
    reg <- xreg[-1,,drop=FALSE] - phi1*xreg[-n,,drop=FALSE]
    R <- c(0, reg %*% betas)
  }

  if (is.null(xt)) {
    # xp is the previous x: x_{t-1}
    Reduce(f = function(xp, t) phi1*xp + mu*(1-phi1) + R[t] + a[t], x = 2:n, init = init, accumulate = TRUE)
  } else {
    c(xt[1],
      phi1*xt[-n] + mu*(1-phi1) + R[-1] + a[-1])
  }
}

set.seed(2020)

x.sim <- sim(10000, mu = 1032, sigma = sqrt(23), phi1 = 0.9, betas = 0, xreg = matrix(1:10000, ncol = 1))
plot(x.sim, type = 'l')
acf(x.sim)
pacf(x.sim)

x.sim.trend <- sim(10000, mu = 1032, sigma = sqrt(23), phi1 = 0.9, betas = 0.005, xreg = matrix(1:10000, ncol = 1))
plot(x.sim.trend, type = 'l')

#' Fit the custom drift detection model
#'
#' If specific parameters are supplied, then they will be fixed.
#'
#' @keywords internal
fit <- function(x, mu = NULL, sigma = NULL, phi1 = NULL,
                betas = if (is.null(xreg)) list() else setNames(vector('list', ncol(xreg)), colnames(xreg)),
                xreg = NULL) {

  stopifnot(is.null(xreg) || is.matrix(xreg))
  stopifnot(!is.matrix(xreg) || length(betas) == ncol(xreg))
  stopifnot(!is.matrix(xreg) || all(names(betas) == colnames(xreg)))

  all.param.names <- c('mu', 'sigma', 'phi1', names(betas))
  stopifnot(length(unique(all.param.names)) == length(all.param.names))

  stopifnot(!any(ls() %in% names(betas)))
  list2env(betas, envir = environment())

  inits <- c(
    'mu'= median(x),
    'sigma' = var(x),
    'phi1' = pacf(x, plot = FALSE, lag.max = 1)$acf[1,1,1],
    if (length(betas) == 0L) NULL else setNames(coef(lm(x ~ xreg))[-1], names(betas))
  )

  scale <- c(
    'mu' = if (length(betas) == 0L) 1 else summary(lm(x ~ xreg))$coefficients[1L, 2L],
    'sigma' = 1,
    'phi1' = 1/100,
    if (length(betas) == 0L) NULL else setNames(summary(lm(x ~ xreg))$coefficients[-1L, 2L], names(betas))
  )

  lower.bound <- c(
    'mu' = -Inf,
    'sigma' = 1e-7,
    'phi1' = -Inf,
    setNames(rep(-Inf, length(betas)), names(betas))
  )

  upper.bound <- c(
    'mu' = Inf,
    'sigma' = Inf,
    'phi1' = 1 - 1e-7,
    setNames(rep(Inf, length(betas)), names(betas))
  )

  fixed <- unlist(mget(all.param.names)[!sapply(mget(all.param.names), is.null)])
  param.names <- setdiff(all.param.names, names(fixed))

  opt <- optim(
    par = inits[param.names],
    fn = logL.compile(mu = mu, sigma = sigma, phi1 = phi1, betas = betas),
    method = 'L-BFGS-B',
    x = x,
    lower = lower.bound[param.names],
    upper = upper.bound[param.names],
    xreg = xreg,
    control = list('fnscale' = -1,
                   'parscale' = scale[param.names],
                   'trace' = 0)
  )

  # Add fixed parameters
  opt <- append(x = opt, values = list('par.fixed' = fixed), after = 1)

  opt
}

xreg.trend.1 <- matrix(data = 1:length(x.sim), dimnames = list(NULL, 'trend'))

# Here specification of likelihood is tested with general arima model.
## x.sim
fit(x = x.sim) # -29832.06
fit(x = x.sim, xreg = xreg.trend.1)
fit(x = x.sim, betas = list('trend' = 0), xreg = xreg.trend.1) # -29832.06

#forecast::auto.arima(y = x.sim, trace = TRUE)
fit.arima <- arima(x = x.sim, order = c(1, 0, 0))
fit.arima # -29835.35

## x.sim.trend
fit(x = x.sim.trend, xreg = xreg.trend.1) # -29997.49
fit.arima <- arima(x = x.sim.trend, order = c(1, 0, 0), xreg = xreg.trend.1)
fit.arima # -30000.82

# Data -------------------------------------------------------------------------

source('./../../gwloggeR/R/fourier.R')

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
  if (nrow(df) == 0L) return(df)
  df <- df[!is.na(TIMESTAMP_UTC), ]
  df <- df[!is.na(PRESSURE_VALUE), ]
  df <- df[!duplicated(TIMESTAMP_UTC), ]
  df <- df[, .('PRESSURE_VALUE' = mean(PRESSURE_VALUE)),
           by = .('TIMESTAMP_UTC' = round_timestamp(TIMESTAMP_UTC))]

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

  data.table::setkey(df, TIMESTAMP_UTC)
  data.table::setattr(df, 'logger.name', logger.name)

  df
}

# from analysis 04
compare <- function(df1, df2) {
  if (nrow(df1) == 0L || nrow(df2) == 0L) return(data.table::data.table())

  diff.df <- df1[J(df2), .('PRESSURE_DIFF' = x.PRESSURE_VALUE - i.PRESSURE_VALUE, TIMESTAMP_UTC)][!is.na(PRESSURE_DIFF), ]

  data.table::setkey(diff.df, TIMESTAMP_UTC)

  diff.df
}

ref.compare <- function(logger.name) {
  compare(read.baro(logger.name), read.baro('KNMI_20200312_hourly'))
}

coef.pvals <- function(M) {
  (1-pnorm(abs(M$coef)/sqrt(diag(M$var.coef))))*2
}

plt.comp <- function(TIMESTAMP_UTC, Y, M = NULL, significant = NULL, front_layer = NULL,
                     xlim = range(TIMESTAMP_UTC), ylim = quantile(Y, c(0.005, 0.995))) {

  force(TIMESTAMP_UTC); force(Y); force(M)
  force(ylim); force(xlim)

  p <- ggplot2::ggplot(mapping = ggplot2::aes(x = TIMESTAMP_UTC, y = Y)) +
    front_layer +
    ggplot2::geom_line(col = 'red', alpha = 0.9)

  if (!is.null(M))
    p <- p + ggplot2::geom_line(mapping = ggplot2::aes(y = fitted(M)), col = 'black', size = 1.5)

  if (!is.null(significant)) {
    p <- p + ggplot2::annotate(
      "label", x = as.POSIXct(-Inf, origin = '1970-01-01'), y = Inf,
      size = 4, col = if (significant) 'green' else 'red',
      hjust = 0, vjust = 1, fill = 'grey', label.size = NA,
      label = if (significant) 'SIGNIFINCANT' else 'NOT SIGNIFICANT'
    )
  }

  if (!is.null(M[['btrend']]) && coef.pvals(M)['btrend'] < 0.001)
    p <- p + ggplot2::geom_vline(xintercept = TIMESTAMP_UTC[which.max(M$btrend > 0)],
                                 col = 'blue', linetype = 'dotted', size = 1.2)

  p <- p +
    ggplot2::coord_cartesian(ylim = ylim, xlim = xlim) +
    ggplot2::ylab('PRESSURE_DIFF') +
    ggplot2::theme_light() +
    ggplot2::theme(axis.text.y = ggplot2::element_text(angle = 90, hjust = 0.5))

  p
}

report <- function(logger.name) {

  environment(plt.comp) <- environment() # fitted(Arima) then can find the source data.

  print(logger.name)

  df.diff <- ref.compare(logger.name)

  if (nrow(df.diff) < 10L) return(invisible(FALSE))

  # M <- fit(x = df.diff$PRESSURE_DIFF, phi1 = 0, d = 0, dsi = 1)
  M <- arima(x = df.diff$PRESSURE_DIFF, order = c(0, 0, 0))
  df.diff[, M_pred := fitted(M)]

  # M.AR <- fit(x = df.diff$PRESSURE_DIFF, d = 0, dsi = 1)
  M.AR <- arima(x = df.diff$PRESSURE_DIFF, order = c(1, 0, 0))
  df.diff[, M.AR.pred := fitted(M.AR)]

  trend <- c(0, cumsum(diff(as.numeric(df.diff$TIMESTAMP_UTC))/3600/24))
  breakpoints <- seq(from = 1, to = nrow(df.diff), by = 10)
  # M.ARD <- M.AR
  # for (bp in breakpoints) {
  #   .M <- fit(x = df.diff$PRESSURE_DIFF, dsi = bp)
  #   if (.M$value > M.ARD$value) M.ARD <- .M
  # }
  M.ARD <- M.AR
  for (bp in breakpoints) {
    btrend <- c(rep(0, bp - 1), trend[bp:length(trend)] - trend[bp])
    .M <- arima(x = df.diff$PRESSURE_DIFF, order = c(1, 0, 0), xreg = btrend)
    .M[['btrend']] <- btrend
    if (logLik(.M) > logLik(M.ARD)) M.ARD <- .M
  }
  df.diff[, M.ARD.pred := fitted(M.ARD)]

  sbasis <- fbasis(timestamps = df.diff$TIMESTAMP_UTC, frequencies = 1/(365.25*3600*24))

  M.ARS <- arima(x = df.diff$PRESSURE_DIFF, order = c(1, 0, 0), xreg = sbasis)

  M.ARDS <- M.ARS
  for (bp in breakpoints) {
    btrend <- c(rep(0, bp - 1), trend[bp:length(trend)] - trend[bp])
    .M <- arima(x = df.diff$PRESSURE_DIFF, order = c(1, 0, 0), xreg = cbind(sbasis, btrend))
    .M[['btrend']] <- btrend
    if (logLik(.M) > logLik(M.ARDS)) M.ARDS <- .M
  }

  p.comp <- plt.comp(df.diff$TIMESTAMP_UTC, df.diff$PRESSURE_DIFF)

  p.M <- plt.comp(df.diff$TIMESTAMP_UTC, df.diff$PRESSURE_DIFF, M)

  p.M.AR <- plt.comp(df.diff$TIMESTAMP_UTC, df.diff$PRESSURE_DIFF, M.AR)

  p.M.ARS <- plt.comp(df.diff$TIMESTAMP_UTC, df.diff$PRESSURE_DIFF, M.ARS)

  p.M.ARD <- plt.comp(df.diff$TIMESTAMP_UTC, df.diff$PRESSURE_DIFF, M.ARD)

  p.M.ARDS <- plt.comp(df.diff$TIMESTAMP_UTC, df.diff$PRESSURE_DIFF, M.ARDS)

  # File export ----------------------------------------------------------------

  filename <- sprintf('./drifts/analysis_25/%s.png', tools::file_path_sans_ext(basename(logger.name)))
  dir.create(dirname(filename), showWarnings = FALSE, recursive = TRUE)

  layout_matrix <- rbind(c(1, 2),
                         c(3, 4),
                         c(5, 6))

  grob.title <- grid::textGrob(sprintf('%s (#%s differences with KNMI data from %s to %s)',
                                       basename(logger.name), nrow(df.diff),
                                       min(df.diff$TIMESTAMP_UTC), max(df.diff$TIMESTAMP_UTC)),
                               x = 0.05, hjust = 0)

  p.empty <- ggplot2::ggplot() + ggplot2::theme_void()

  local({
    png(filename, width = 1280, height = 720)
    on.exit(dev.off())
    gridExtra::grid.arrange(p.comp, p.empty,
                            p.M, p.M.ARS,
                            p.M.ARD, p.M.ARDS,
                            layout_matrix = layout_matrix,
                            top = grob.title)
  })

  invisible(TRUE)

}

# report('BAOL009X_78680')
invisible(lapply(logger.names, report))


doors_puzzle <- function(ndoors=100,passes=100) {
    doors <- rep(FALSE,ndoors)
    for (ii in seq(1,passes)) {
        mask <- seq(0,ndoors,ii)
        doors[mask] <- !doors[mask]
    }
    return (which(doors == TRUE))
}

doors_puzzle()


# 07. Beta Diversity
# Figure 3c, Figure 5c, Figure S6, Figure S10
# Ref for CLR PCA: Gloor, G. B.; Macklaim, J. M.; Pawlowsky-Glahn, V.; Egozcue, J. J. Microbiome Datasets Are Compositional: And This Is Not Optional. Front. Microbiol. 2017, 8. https://doi.org/10.3389/fmicb.2017.02224.
# Ref for PhILR PCA: Silverman, J. D.; Washburne, A. D.; Mukherjee, S.; David, L. A. A Phylogenetic Transform Enhances Analysis of Compositional Microbiota Data. eLife 2017, 6, e21887. https://doi.org/10.7554/eLife.21887.
# Water and sediment sequences were analyzed separately

#### Phyloseq Object ####
ps.noncontam.tree

#### Set Directory ####
beta <- file.path(paste(path_phy, "/beta_diversity/Ordination", sep=""))
dir.create(beta, showWarnings=FALSE, recursive=TRUE)
setwd(beta)

#### CLR transformation ####
set.seed(2021)

# Obtain the OTU table
ps_filt_otu <- as.data.frame(otu_table(ps.noncontam.tree))
metadata <- as.data.frame(as.matrix(sample_data(ps.noncontam.tree)))

# Transform the OTU table and replace 0 values with an estimate
f.n0 <- cmultRepl(t(ps_filt_otu), method="CZM", label=0, output="p-counts")

# CLR Transformation
f.clr <- codaSeq.clr(f.n0, IQLR=FALSE)
head(f.clr)

# Check distribution
qplot(rowSums(f.clr),bins=50) + xlab("clr transformed counts-per-sample")
qplot(colSums(f.clr),bins=50) + xlab("clr transformed counts-per-taxa")

# Add CLR to phyloseq object
ps_clr <- phyloseq(
    otu_table(t(f.clr), taxa_are_rows = TRUE),
    sample_data(sample_data(ps.noncontam.tree)),
    phy_tree(filt_tree),
    tax_table(tax_table(ps.noncontam.tree))
)
ps_clr

# get PCA
f.pcx <- prcomp(f.clr)

# extract results from PCA
var <- get_pca_var(f.pcx)

# get eigenvalue
eig.val <- get_eigenvalue(f.pcx)
head(eig.val)

#### PhILR transformation ####
library("philr")

# Add clr to phyloseq object
ps_philr <- phyloseq(
    otu_table(t(f.n0), taxa_are_rows = TRUE),
    sample_data(sample_data(ps.noncontam.tree)),
    phy_tree(filt_tree),
    tax_table(tax_table(ps.noncontam.tree))
)
ps_philr

# check the object
is.rooted(phy_tree(ps_philr))
is.binary.tree(phy_tree(ps_philr))

# labels and name balance
phy_tree(ps_philr) <- makeNodeLabel(phy_tree(ps_philr), method="number", prefix='n')

name.balance(phy_tree(ps_philr), tax_table(ps_philr), 'n1')

# calculate philr
otu.table <- as.data.frame(otu_table(ps_philr))
otu.table <- as.matrix(t(otu.table))
tree <- phy_tree(ps_philr)
metadata <- sample_data(ps_philr)
tax <- tax_table(ps_philr)

gp.philr <- philr(otu.table, tree, part.weights='enorm.x.gm.counts', ilr.weights='blw.sqrt', return.all=TRUE)

# get philr info
gp.dist <- dist(gp.philr$df.ilrp, method="euclidean")
gp.pcoa <- ordinate(ps_philr, 'PCoA', distance=gp.dist)

#### Prepare for combining CLR and PhILR data to plot (Water Samples) ####
ordi_clr <- as.data.frame(f.pcx$x[,1:2])
ordi_clr$ID_keep <- rownames(ordi_clr)
head(ordi_clr)

DATA_PHYLOSEQ_FIXED$ID_keep <- rownames(DATA_PHYLOSEQ_FIXED)
ordi_data <- merge(DATA_PHYLOSEQ_FIXED, ordi_clr, by = c('ID_keep'))
ordi_data$strat_time <- ifelse(ordi_data$Season == "Fall", "Stratified (~7 months)",
                  ifelse(ordi_data$Season == "Spring", "Incipient Stratification",
                         ifelse(ordi_data$Season == "Summer", "Stratified (~3 months)", "")))
ordi_data$strat_time <- factor(ordi_data$strat_time, ordered = TRUE, levels = c("Incipient Stratification", "Stratified (~3 months)", "Stratified (~7 months)"))

ordi.scores_philr <- as.data.frame(gp.pcoa$vectors)
colnames(ordi.scores_philr) <- c("Axis.1philr", "Axis.2philr")
ordi.scores_philr <- ordi.scores_philr[c("Axis.1philr","Axis.2philr")]
ordi.scores_philr$ID_keep <- rownames(ordi.scores_philr)

# Merge data with ordi_data
ordi_data <- merge(ordi_data, ordi.scores_philr, by = c('ID_keep'))
head(ordi_data)
colnames(ordi_data)

# remove bad samples
ordi_data_sub <- subset(ordi_data, SampleID != "W64")
ordi_data_sub <- subset(ordi_data_sub, SampleID != "W66")
ordi_data_sub <- subset(ordi_data_sub, SampleID != "W67")

# remove batch 4 (same as batch 1 and 3)
ordi_data_sub_NoBatch4 <- subset(ordi_data_sub, Sequence_batch != "Batch4")

# data for plotting batches
ordi_data_sub_batch <- subset(ordi_data_sub, Plot_batch == "Y")

#### Prepare for combining CLR and PhILR data to plot (Sediment Samples) ####
# CLR
ordi_clr = ordinate(ps_clr, "PCoA", "euclidean")
head(ordi_clr$values)
head(ordi_clr$vectors)

ordi.scores_clr <- as.data.frame(ordi_clr$vectors)
ordi.scores_clr[,3:20] <- NULL
colnames(ordi.scores_clr) <- c("Axis.1clr", "Axis2.clr")
ordi.scores_clr$ID_keep <- rownames(ordi.scores_clr)

# PhILR
ordi.scores_philr <- as.data.frame(gp.pcoa$vectors)
ordi.scores_philr[,3:20] <- NULL
colnames(ordi.scores_philr) <- c("Axis.1philr", "Axis.2philr")
ordi.scores_philr$ID_keep <- rownames(ordi.scores_philr)

# Merge data with ordi_data
DATA_PHYLOSEQ_FIXED$ID_keep <- rownames(DATA_PHYLOSEQ_FIXED)
ordi_data <- merge(DATA_PHYLOSEQ_FIXED, ordi.scores_clr, by = c('ID_keep'))
ordi_data <- merge(ordi_data, ordi.scores_philr, by = c('ID_keep'))
head(ordi_data)

#### Plot CLR and PhILR PCA ####
# Set up theme
plot_theme <- theme(panel.background = element_rect(fill = "white", colour = "black", size = 1, linetype = "solid"),
    panel.border = element_rect(colour="black", size=1, fill=NA),
    strip.background=element_rect(fill='white', colour='white', size = 0),
    strip.text = element_text(face="bold", size=20),
    panel.spacing.x=unit(0.5, "lines"),
    panel.grid.major = element_line(size = 0),
    panel.grid.minor = element_line(size = 0),
    axis.text = element_text(size=15, colour="black"),
    axis.title = element_text(face="bold", size=20),
    legend.position="right",
    legend.key = element_rect(fill = "transparent"),
    legend.title = element_text(face="bold", size=20),
    legend.text = element_text(size=20),
    legend.background = element_rect(fill = "transparent"),
    legend.box.background = element_rect(fill = "transparent", colour = NA))
plot_guide <- guides(fill = guide_colourbar(frame.linewidth = 1, frame.colour = "black", ticks = TRUE, ticks.colour = "black", ticks.linewidth = 1, reverse=T),
    shape = guide_legend(order=1, override.aes = list(size = 5, color="black", alpha=1)),
    color = "none")

### CLR PCA
## Water Samples
clr_plot_final <- ggplot(ordi_data_sub_NoBatch4, aes(x=PC1, y = PC2)) +
    geom_hline(yintercept=0, size=.2, linetype = "dashed", color="black") + geom_vline(xintercept=0, size=.2, linetype = "dashed", color="black") +
    geom_point(color="black", size=4, aes(fill=Depth_meters, shape=strat_time)) +
    xlab(paste("PC1: 29.2%")) +
    ylab(paste("PC2: 15.3%")) +
    scale_shape_manual(name = "Stratification?", values=c(21, 23, 24)) +
    scale_fill_gradient2(name = "Depth (m)", breaks = c(0, 2, 6, 10), limits = c(0, 10), low="#fffab1", mid="#ed105f", high="#023e73", midpoint=5) +
     plot_theme + plot_guide
clr_plot_final

save_file <- paste("clr.pdf", sep="")
ggsave(save_file, path = beta, scale = 1, width = 8, height = 5, units = c("in"), dpi = 300)

# label CLR PCA
clr_plot_label <- clr_plot_final +
    geom_label_repel(aes(label = SampleID), box.padding = 0.35, point.padding = 0.5, segment.color = 'grey50', max.overlaps=Inf)

save_file <- paste("clr_labelled.pdf", sep="")
ggsave(save_file, path = beta, scale = 1, width = 8, height = 5, units = c("in"), dpi = 300)

# Plot batches CLR PCA
plot_guide <- guides(shape = guide_legend(order=1, override.aes = list(size = 5, color="black", alpha=1)),
                     color = "none")
ordi_data_sub_batch$Sequence_batch <- gsub("Batch1", "Batch 1", ordi_data_sub_batch$Sequence_batch)
ordi_data_sub_batch$Sequence_batch <- gsub("Batch2", "Batch 2", ordi_data_sub_batch$Sequence_batch)
ordi_data_sub_batch$Sequence_batch <- gsub("Batch3", "Batch 3", ordi_data_sub_batch$Sequence_batch)
ordi_data_sub_batch$Sequence_batch <- gsub("Batch4", "Batch 4", ordi_data_sub_batch$Sequence_batch)

clr_plot_batch <- ggplot(ordi_data_sub_batch, aes(x=PC1, y = PC2)) +
    geom_hline(yintercept=0, size=.2, linetype = "dashed", color="black") + geom_vline(xintercept=0, size=.2, linetype = "dashed", color="black") +
    geom_point(color="black", size=4, shape=21, aes(fill=Sequence_batch)) +
    xlab(paste("PC1: 29.2%")) +
    ylab(paste("PC2: 15.3%")) +
    scale_fill_manual(name="Sequence Batch", values = c("#003566", "#ffc300", "#ed105f")) +
    plot_theme + plot_guide

save_file <- paste("clr_plot_batch.pdf", sep="")
ggsave(save_file, path = beta, scale = 1, width = 8, height = 5, units = c("in"), dpi = 300)

# label CLR PCA batch
clr_plot_batch_label <- clr_plot_batch +
    geom_label_repel(aes(label = SampleID), box.padding = 0.35, point.padding = 0.5, segment.color = 'grey50', max.overlaps=Inf)
clr_plot_batch_label

save_file <- paste("clr_plot_batch_labelled.pdf", sep="")
ggsave(save_file, path = beta, scale = 1, width = 8, height = 5, units = c("in"), dpi = 300)

## Sediment Samples
clr_plot_final <- ggplot(ordi_data, aes(x=Axis.1clr, y = Axis2.clr)) +
    geom_hline(yintercept=0, size=.2, linetype = "dashed", color="black") + geom_vline(xintercept=0, size=.2, linetype = "dashed", color="black") +
    geom_point(color="black", size=4, aes(fill=Location_description, shape=Depth_desc)) +
    xlab(paste("PC1: 23.6%")) +
    ylab(paste("PC2: 10.8%")) +
    scale_shape_manual(name = "Depth layer", values=c(25, 21, 22)) +
    scale_fill_manual(name = "Location", values=c("#dcab6b", "#9be564")) +
    plot_theme + plot_guide
clr_plot_final

# save file
save_file <- paste("PCA_clr.pdf", sep="")
ggsave(save_file, path = beta, scale = 1, width = 9, height = 5, units = c("in"), dpi = 300)

# label plot
clr_plot_label <- clr_plot_final +
geom_label_repel(aes(label = SampleID), box.padding = 0.35, point.padding = 0.5, segment.color = 'grey50', max.overlaps=Inf)
pca_clr_label

# save file
save_file <- paste("PCA_clr_labelled.pdf", sep="")
ggsave(save_file, path = beta, scale = 1, width = 9, height = 5, units = c("in"), dpi = 300)

### Plot PhILR PCA
## Water Samples
plot_guide <- guides(fill = guide_colourbar(frame.linewidth = 1, frame.colour = "black", ticks = TRUE, ticks.colour = "black", ticks.linewidth = 1, reverse=T),
    shape = guide_legend(order=1, override.aes = list(size = 5, color="black", alpha=1)),
    color = "none")

philr_plot_final <- ggplot(ordi_data_sub_NoBatch4, aes(x=Axis.1philr, y = Axis.2philr)) +
    geom_hline(yintercept=0, size=.2, linetype = "dashed", color="black") + geom_vline(xintercept=0, size=.2, linetype = "dashed", color="black") +
    geom_point(color="black", size=4, aes(fill=Depth_meters, shape=strat_time)) +
    xlab(paste("PC1: 53.8%")) +
    ylab(paste("PC2: 14.5%")) +
    scale_shape_manual(name = "Stratification?", values=c(21, 23, 24)) +
    scale_fill_gradient2(name = "Depth (m)", breaks = c(0, 2, 6, 10), limits = c(0, 10), low="#fffab1", mid="#ed105f", high="#023e73", midpoint=5) +
     plot_theme + plot_guide
philr_plot_final

save_file <- paste("philr.pdf", sep="")
ggsave(save_file, path = beta, scale = 1, width = 8, height = 5, units = c("in"), dpi = 300)

# label PhILR PCA plot
philr_plot_label <- philr_plot_final +
    geom_label_repel(aes(label = SampleID), box.padding = 0.35, point.padding = 0.5, segment.color = 'grey50', max.overlaps=Inf)

save_file <- paste("philr_labelled.pdf", sep="")
ggsave(save_file, path = beta, scale = 1, width = 8, height = 5, units = c("in"), dpi = 300)

# plot batches PhILR PCA
plot_guide <- guides(shape = guide_legend(order=1, override.aes = list(size = 5, color="black", alpha=1)),
                     color = "none")

philr_plot_batch <- ggplot(ordi_data_sub_batch, aes(x=Axis.1philr, y = Axis.2philr)) +
    geom_hline(yintercept=0, size=.2, linetype = "dashed", color="black") + geom_vline(xintercept=0, size=.2, linetype = "dashed", color="black") +
    geom_point(color="black", size=4, shape=21, aes(fill=Sequence_batch)) +
    xlab(paste("PC1: 53.8%")) +
    ylab(paste("PC2: 14.5%")) +
    scale_fill_manual(name="Sequence Batch", values = c("#003566", "#ffc300", "#ed105f")) +
    plot_theme + plot_guide

save_file <- paste("philr_plot_batch.pdf", sep="")
ggsave(save_file, path = beta, scale = 1, width = 8, height = 5, units = c("in"), dpi = 300)

# label PhILR PCA batch
philr_plot_batch_label <- philr_plot_batch +
    geom_label_repel(aes(label = SampleID), box.padding = 0.35, point.padding = 0.5, segment.color = 'grey50', max.overlaps=Inf)
philr_plot_batch_label

save_file <- paste("philr_plot_batch_labelled.pdf", sep="")
ggsave(save_file, path = beta, scale = 1, width = 8, height = 5, units = c("in"), dpi = 300)

## Sediment Samples
philr_plot_final <- ggplot(ordi_data, aes(x=Axis.1philr, y = Axis.2philr)) +
    geom_hline(yintercept=0, size=.2, linetype = "dashed", color="black") + geom_vline(xintercept=0, size=.2, linetype = "dashed", color="black") +
    geom_point(color="black", size=4, aes(fill=Location_description, shape=Depth_desc)) +
    xlab(paste("PC1: 52.7%")) +
    ylab(paste("PC2: 8.7%")) +
    scale_shape_manual(name = "Depth layer", values=c(25, 21, 22)) +
    scale_fill_manual(name = "Location", values=c("#dcab6b", "#9be564")) +
    plot_theme + plot_guide
philr_plot_final

# save file
save_file <- paste("PCA_philr.pdf", sep="")
ggsave(save_file, path = beta, scale = 1, width = 9, height = 5, units = c("in"), dpi = 300)

# label plot
philr_plot_label <- philr_plot_final +
geom_label_repel(aes(label = SampleID), box.padding = 0.35, point.padding = 0.5, segment.color = 'grey50', max.overlaps=Inf)
pca_philr_label

# save file
save_file <- paste("PCA_philr_labelled.pdf", sep="")
ggsave(save_file, path = beta, scale = 1, width = 9, height = 5, units = c("in"), dpi = 300)

### combine CLR and PhILR PCA plots (Figure 3c, Figure 5c, Figure S6, Figure S10)
both <- plot_grid(clr_plot_final + theme(legend.position="none"),
                 philr_plot_final + theme(legend.position="none"),
                 ncol=2, align = "v", axis="b")

save_file <- paste("Combo_ordination.pdf", sep="")
ggsave(save_file, path = beta, plot = both, scale = 1, width = 10, height = 5, units = c("in"), dpi = 300)

# Water Samples Labelled
both <- plot_grid(clr_plot_batch_label + theme(legend.position="none"),
                 philr_plot_batch_label + theme(legend.position="none"),
                 ncol=3, align = "v", axis="b")

# Sediment Samples Labelled
both <- plot_grid(clr_plot_label + theme(legend.position="none"),
                 philr_plot_label + theme(legend.position="none"),
                 ncol=3, align = "v", axis="b")

save_file <- paste("Combo_ordination_batch_labelled.svg", sep="")
ggsave(save_file, path = beta, plot = both, scale = 1, width = 15, height = 5, units = c("in"), dpi = 300)

#### Stats on beta diversity ####

# obtain distance matrix CLR
ordi_clr_dist <- as.matrix(phyloseq::distance(ps_clr, method="euclidean"))
head(ordi_clr_dist)

# obtain distance matrix PhILR
ordi_philr_dist <- as.matrix(gp.dist)
head(ordi_philr_dist)

# Water ADONIS
adonis2(ordi_clr_dist~DATA_PHYLOSEQ_FIXED$Depth_cat + DATA_PHYLOSEQ_FIXED$Location_description + DATA_PHYLOSEQ_FIXED$Season, permutations=999, by="margin", method="euclidean")
adonis2(ordi_philr_dist~DATA_PHYLOSEQ_FIXED$Depth_cat + DATA_PHYLOSEQ_FIXED$Location_description + DATA_PHYLOSEQ_FIXED$Season, permutations=999, by="margin", method="euclidean")

# Sediment ADONIS
adonis2(ordi_clr_dist~DATA_PHYLOSEQ_FIXED$Location + DATA_PHYLOSEQ_FIXED$Depth_cat, permutations=999, by="margin", method="euclidean")
adonis2(ordi_philr_dist~DATA_PHYLOSEQ_FIXED$Location + DATA_PHYLOSEQ_FIXED$Depth_cat, permutations=999, by="margin", method="euclidean")

# Water Geochem ADONIS
adonis2(ordi_clr_dist~
        DATA_PHYLOSEQ_FIXED$Fe_mg_L+
        DATA_PHYLOSEQ_FIXED$ChlA_RFU+
        DATA_PHYLOSEQ_FIXED$DO_percSat+
        DATA_PHYLOSEQ_FIXED$TDS_ppt+
        DATA_PHYLOSEQ_FIXED$pH+
        DATA_PHYLOSEQ_FIXED$Temp_C+
        DATA_PHYLOSEQ_FIXED$Fe_mg_L, permutations=999, by="margin", method="euclidean")

adonis2(ordi_philr_dist~
    DATA_PHYLOSEQ_FIXED$Fe_mg_L+
    DATA_PHYLOSEQ_FIXED$ChlA_RFU+
    DATA_PHYLOSEQ_FIXED$DO_percSat+
    DATA_PHYLOSEQ_FIXED$TDS_ppt+
    DATA_PHYLOSEQ_FIXED$pH+
    DATA_PHYLOSEQ_FIXED$Temp_C+
    DATA_PHYLOSEQ_FIXED$Fe_mg_L, permutations=999, by="margin", method="euclidean")


# Prediction efficiency in two ways, plus identity of taxa for which we obtain a, b, c or d
prediction_accuracy_id <- function(predicted, empirical) {
    # Parameters:
    #   predicted   matrix of predicted interactions
    #   empirical   matrix of empirical interactions

    #   Output      vector of a, b, c, d, and TSS
    #       a       number of links predicted (1) and observed (1)
    #       b       number predicted (1) but not observed (0)
    #       c       number predicted absent (0) but observed (1)
    #       d       number of predicted absent (0) and observed absent (0)
    #       TSS     TSS = (ad-bc)/[(a+c)(b+d)]
    #                   "[...] quantifies the proportion of prediction success relative to false predictions
    #                   and returns values ranging between 1 (perfect predictions) and 1 (inverted forecast)
    #                   (Allouche, Tsoar & Kadmon 2006)." Gravel et al. 2013
    #       ScoreY1 Fraction of 1 correctly predicted a / (a + c)
    #       ScoreY0 Fraction of 0 correctly predicted d / (b + d)
    #       FSS     FSS = ScoreY1 + ScoreY0 / sum(a, b, c, d)^2

    if(identical(colnames(predicted), colnames(empirical)) == FALSE ||
        identical(rownames(predicted), rownames(empirical)) == FALSE ||
        identical(dim(predicted), dim(empirical)) == FALSE) {
            print('matrices need to have same dimensions and row and column names')
            break
    }

    efficiency <- numeric(8)
    aa <- bb <- cc <- dd <-  numeric(2)
    names(efficiency) <- c('a','b','c','d','TSS','ScoreY1','ScoreY0','FSS')

    for(i in 1:ncol(predicted)){
        for(j in 1:nrow(predicted)) {
            if(predicted[i,j] == 1 && empirical[i,j] == 1) {
                efficiency[1] <- efficiency[1] + 1
                aa <- rbind(aa,c(j,i))
            } else if(predicted[i,j] == 1 && empirical[i,j] == 0) {
                efficiency[2] <- efficiency[2] + 1
                bb <- rbind(bb,c(j,i))
            } else if(predicted[i,j] == 0 && empirical[i,j] == 1) {
                efficiency[3] <- efficiency[3] + 1
                cc <- rbind(cc,c(j,i))
            } else if(predicted[i,j] == 0 && empirical[i,j] == 0) {
                efficiency[4] <- efficiency[4] + 1
                dd <- rbind(dd,c(j,i))
            }
        }
    }

    a <- efficiency[1]
    b <- efficiency[2]
    c <- efficiency[3]
    d <- efficiency[4]

    efficiency[5] <- ((a * d) - (b * c)) / ((a + c) * (b + d))  # TSS
    efficiency[6] <- a / (a + c)                                # ScoreY1
    efficiency[7] <- d / (b + d)                                # ScoreY0
    efficiency[8] <- (a + d) / sum(a, b, c, d)    # FSS

    efficiency.id <- vector('list',5)
    efficiency.id[[1]] <- efficiency
    efficiency.id[[2]] <- aa
    efficiency.id[[3]] <- bb
    efficiency.id[[4]] <- cc
    efficiency.id[[5]] <- dd

    return(efficiency.id)
}


# read dat
# the dataset is not on github (it is proprietary data)
myData = read.csv("E:teaching/2015_acg5075_r/wrds_data/1db085f4e5130fbb.csv")

#number of obs
nrow(myData)
#[1] 6392

#show first records
head(myData)

#Tobin's q
myData$q <- (myData$at - myData$ceq + myData$prcc_f * myData$csho) / myData$at

# keep if assets are positive (would get infinite q values otherwise)
myData <- myData [ myData$at > 0,]

#number of obs is now lower
nrow(myData)
#[1] 6354

# drop rows where q is not numeric
# use of complete.cases: http://stat.ethz.ch/R-manual/R-patched/library/stats/html/complete.cases.html
myData <- myData[complete.cases(myData),]

#create variable that holds yearly median q, fun is function to apply (median)
myAvg <- aggregate(myData$q, by=list(myData$fyear), FUN=median)

# as matrix (easier to deal with)
asM <- as.matrix(myAvg)
asM
#       Group.1         x
#  [1,]    1999 1.3138537
#  [2,]    2000 1.4681244
#  [3,]    2001 1.3413399
#  [4,]    2002 1.3786471
#  [5,]    2003 1.6268107
#  [6,]    2004 1.8003359
#  [7,]    2005 2.0561987
#  [8,]    2006 1.7072194
#  [9,]    2007 1.5274536
# [10,]    2008 0.9915084
# [11,]    2009 1.3756427
# [12,]    2010 1.6999887
# [13,]    2011 1.3850571
# [14,]    2012 1.2670636
# [15,]    2013 1.2941523

#plot: first argument specifies column with numbers, second argument specifies column with names
barplot(asM[ ,2], names.arg = asM[ ,1])

#more here, http://www.harding.edu/fmccown/r/


khat.new=function(h,p){
num=(1-((h^2+2)/h^2)^(-p/2))^2
din = ((h^2 + 4)/h^2)^(-p/2) - 2 * ((h^2 + 1)/h^2)^(-p/2) *
        ((h^2 + 3)/h^2)^(-p/2) + ((h^2 + 2)/h^2)^(-p)
dof=num/din
return(p * (dof^(1/p) - 1)/2)
}

khat.direct=function(h,p,k) khat.new(h,p)-k

hvec=function(p,len=10){
kvec=seq(2,15,length.out=len)
h=rep(0,length=len)
for (i in 1:len){
h[i]=uniroot(khat.direct, c(0.1,7), p=p,k=kvec[i])$root
}
return(h)
}