=begin
[((<index-ja|URL:index-ja.html>))]
((<Algebra::MatrixAlgebra>))
/
((<Algebra::Vector>))
/
((<Algebra::Covector>))
/
((<Algebra::SquareMatrix>))
/
((<Algebra::GaussianElimination>))

= Algebra::MatrixAlgebra
((*(行列クラス)*))

行列を表現します。実際のクラスを生成するには基底環とサイズを指定して、
クラスメソッド ((<::create>)) あるいは関数 ((<Algebra::MatrixAlgebra>))()
を用います。

サブクラスとして ((<Algebra::Vector>))(縦ベクトル）,
((<Algebra::Covector>))(横ベクトル),
((<Algebra::SquareMatrix>))(正方行列) を持ちます。

== ファイル名:
* ((|matrix-algebra.rb|))

== スーパークラス:

* ((|Object|))

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

* ((<Algebra::GaussianElimination>))
* Enumerable

== 関連する関数:

--- Algebra.MatrixAlgebra(ring, m, n)
    ((<::create>))(ring, m, n)と同じです。

== クラスメソッド:

--- ::create(ring, m, n)
    環 ((|ring|)) を要素とする, (({ (m, n) })) 型の行列を
    表現するクラスを生成します。

    このメソッドの戻り値は ((<Algebra::MatrixAlgebra>)) クラスのサブクラス
    です。このサブクラスにはクラスメソッドとして ((|ground|)) と
    ((|rsize|)), ((|csize|)),  ((|sizes|)) が定義され、それぞれ、
    基底となる環 ((|ring|))、行のサイズ ((|m|))、列のサイズ ((|n|))、
    それらの配列 (({ [m, n] })) を返します。

    実際に行列を作るには ((<::new>)),  ((<::matrix>)),
    ((<::[]>)) を使います。

--- ::new(array)
    ((|array|)) を配列の配列とするとき、それを要素とする行列を返します。

    例:
      M = Algebra.MatrixAlgebra(Integer, 2, 3)
      a = M.new([[1, 2, 3], [4, 5, 6]])
      a.display
        #=> [1, 2, 3]
        #=> [4, 5, 6]

--- ::matrix{|i, j| ... }
    ((|i|)) と ((|j|)) に行と列のインデックスを与え ... を評価した値を
    (({ (i, j) })) 成分にした行列を返します。

    例:
      M = Alebra.MatrixAlgebra(Integer, 2, 3)
      a = M.matrix{|i, j| 10*(i + 1) + j + 1}
      a.display
        #=> [11, 12, 13]
        #=> [21, 22, 23]

--- ::[](array1, array2, ..., arrayr)
    配列 (({array1, array2, ..., arrayr})) をそれぞれ行とする配列を返します。

    例:
      M = Algebra.MatrixAlgebra(Integer, 2, 3)
      a = M[[1, 2, 3], [4, 5, 6]]
      a.display
        #=> [1, 2, 3]
        #=> [4, 5, 6]

--- ::collect_ij{|i, j| ... }
    ((<::matrix>)) によく似ていますが、
    返り値は Algebra::MatrixAlgebra でなく、2重配列(Array の Array)です。

--- ::collect_row{|i| ... }
    第 i 行に ... を評価して得た配列を並べた行列を返します。

    例:
      M = Algebra.MatrixAlgebra(Integer, 2, 3)
      A = M.collect_row{|i| [i*10 + 11, i*10 + 12, i*10 + 13]}
      A.display
        #=> [11, 12, 13]
        #=> [21, 22, 23]

--- ::collect_column{|j| ... }
    第 j 列に ... を評価して得た配列を並べた行列を返します。

    例:
      M = Algebra.MatrixAlgebra(Integer, 2, 3)
      A = M.collect_column{|j| [11 + j, 21 + j]}
      A.display
        #=> [11, 12, 13]
        #=> [21, 22, 23]

--- ::*(otype)
    2つの行列の型を掛けた新しいクラスを返します。

    例:
      M = Algebra.MatrixAlgebra(Integer, 2, 3)
      N = Algebra.MatrixAlgebra(Integer, 3, 4)
      L = M * N
      p L.sizes #=> [3, 4]

--- ::vector_type
    ((<rsize>)) と同じサイズの縦ベクトル(Vector)クラスを返します。

--- ::covector_type
    ((<csize>)) と同じサイズの横ベクトル(CoVector)クラスを返します。

--- ::transpose
    転置を行った新しい行列クラスを返します。

--- ::zero
    零行列を返します。

#--- ::matrices; Matrices; end
#--- ::regulate(x)

== メソッド:
#--- dup
--- [](i, j)
    (({(i, j)})) 成分を返します。

--- []=(i, j, x)
    (({(i, j)})) 成分を x にします。

--- rsize
    行サイズを返します。((<::rsize>)) と同じです。

--- csize
    列サイズを返します。((<::csize>)) と同じです。

--- sizes
    [((<rsize>)), ((<csize>))] の配列を返します。
    ((<::sizes>)) と同じです。

--- rows
    各行を要素とする配列を返します。

    例:
      M = Algebra.MatrixAlgebra(Integer, 2, 3)
      a = M.new([[1, 2, 3], [4, 5, 6]])
      p a.rows #=> [[1, 2, 3], [4, 5, 6]]
      p a.row(1) #=> [4, 5, 6]
      a.set_row(1, [40, 50, 60])
      a.display #=> [1, 2, 3]
                #=> [40, 50, 60]

--- row(i)
    i 行目を配列として返します。

--- set_row(i, array)
    i 行目を配列 array に入れ換えます。

--- columns
    各列を要素とする配列を返します。

    例:
      M = Algebra.MatrixAlgebra(Integer, 2, 3)
      a = M.new([[1, 2, 3], [4, 5, 6]])
      p a.columns #=> [[1, 4], [2, 5], [3, 6]]
      p a.column(1) #=> [2, 5]
      a.set_column(1, [20, 50])
      a.display #=> [1, 20, 3]
                #=> [4, 50, 6]

--- column(j)
    j 列目を配列として返します。

--- set_column(j, array)
    j 列目を配列 array に入れ換えます。

--- each{|row| ...}
    各行を配列にして ((|row|)) に入れるイテレータです。

--- each_index{|i, j| ...}
    各添え字 (({ (i, j) })) に関するイテレータです。

--- each_i{|i| ...}
    各行の添え字 (({i})) に関するイテレータです。

--- each_j{|j| ...}
    各列の添え字 (({j})) に関するイテレータです。

--- each_row{|r| ... }
    各行を配列にして ((|r|)) に入れるイテレータです。
    ((<each>)) と同じです。

--- each_column{|c| ... }
    各列を配列にして ((|c|)) に入れるイテレータです。

--- matrix{|i, j| ... }
    ((<::matrix>)) と同じです。

--- collect_ij{|i, j| ... }
    ((<::collect_ij>)) と同じです。

--- collect_row{|i| ... }
    ((<::collect_row>)) と同じです。

--- collect_column{|j| ... }
    ((<::collect_column>)) と同じです。

--- minor(i, j)
    ((|i|)) 行 ((|j|)) 列を除いた小行列を返します。

--- cofactor(i, j)
    ((|i|)) 行 ((|j|)) 列を除いた小行列式に (-1)**(i+j) を掛けたものを
    返します。(({minor(i, j) ** (i + j)})) と同じです。

--- cofactor_matrix
    余因子行列を返します。(({self.class.transpose.matrix{|i, j| cofactor(j, i)}})) と同じです。

--- adjoint
    ((<cofactor_matrix>)) と同じです。

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

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

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

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

    例:
      M = Algebra.MatrixAlgebra(Integer, 2, 3)
      N = Algebra.MatrixAlgebra(Integer, 3, 4)
      L = M * N
      a = M[[1, 2, 3], [4, 5, 6]]
      b = N[[-3, -2, -1, 0], [1, 2, 3, 4], [5, 6, 7, 8]]
      c = a * b
      p c.type  #=> L
      c.display #=> [14, 20, 26, 32]
                #=> [23, 38, 53, 68]

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

--- /(other)
    商を計算します。

--- rank
    階数を返します。

--- dsum(other)
    直和を返します。

    例:
      a = Algebra.MatrixAlgebra(Integer, 2, 3)[
            [1, 2, 3],
            [4, 5, 6]
          ]
      b = Algebra.MatrixAlgebra(Integer, 3, 2)[
            [-1, -2],
            [-3, -4],
            [-5, -6]
          ]
      (a.dsum b).display #=> 1,   2,   3,   0,   0
                         #=> 4,   5,   6,   0,   0
                         #=> 0,   0,   0,  -1,  -2
                         #=> 0,   0,   0,  -3,  -4
                         #=> 0,   0,   0,  -5,  -6

--- convert_to(ring)
    ((|self|)) の各成分を行列環 ((|ring|)) にコンバートします。

    Example:
      require "matrix-algebra"
      require "residue-class-ring"
      Z3 = Algebra.ResidueClassRing(Integer, 3)
      a = Algebra.MatrixAlgebra(Integer, 2, 3)[
        [1, 2, 3],
        [4, 5, 6]
      ]
      a.convert_to(Algebra.MatrixAlgebra(Z3, 2, 3)).display
                                          #=>  1,   2,   0
                                          #=>  1,   2,   0

--- to_ary
    ((|to_a|)) を返します。((|to_a|)) は ((|Enumerable|)) で定義されています。

--- flatten
    ((|to_a.flatten|)) を返します。

--- diag
    対角成分を配列で返します。

--- transpose
    転置行列を返します。

    例:
      M = Algebra.MatrixAlgebra(Integer, 2, 3)
      a = M.new([[1, 2, 3], [4, 5, 6]])
      Mt = M.transpose
      b = a.transpose
      p b.type  #=> Mt
      b.display #=> [1, 4]
                #=> [2, 5]
                #=> [3, 6]

#--- to_s

--- dup
    複製します。

    例:
      M = Algebra.MatrixAlgebra(Integer, 2, 3)
      a = M.new([[1, 2, 3], [4, 5, 6]])
      b = a.dup
      b[1, 1] = 50
      a.display #=> [1, 2, 3]
                #=> [4, 5, 6]
      b.display #=> [1, 2, 3]
                #=> [4, 50, 6]

--- display([out])
    行列を ((|out|)) に表示します。((|out|)) が省略されると ((|$stdout|))
    に表示します。

#--- inspect

= Algebra::Vector
((*(縦ベクトルクラス)*))

ベクトルのクラスです。

== スーパークラス:

* ((|Algebra::MatrixAlgebra|))

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

なし

== 関連する関数:

--- Algebra.Vector(ring, n)
    ((<Algebra::Vector::create>))(ring, n) と同じです。

== クラスメソッド:

--- Algebra::Vector::create(ring, n)
    環 ((|ring|)) を要素とする, ((|n|)) 次元のベクトル（縦ベクトル）
    表現するクラスを生成します。

    このメソッドの戻り値は ((<Algebra::Vector>)) クラスのサブクラス
    です。このサブクラスにはクラスメソッドとして ((|ground|)) と
    ((|size|)) が定義され、それぞれ、基底となる環 ((|ring|))、
    サイズ ((|n|)) を返します。

    実際にベクトルを作るにはクラスメソッド ((|new|)),
    ((|matrix|)),
    ((|[]|)) を使います。

    ((<Algebra::Vector>)) は ((|n|)) 行 1 列の
    ((<Algebra::MatrixAlgebra>)) と同一視されます。

--- Algebra::Vector::new(array)
    ((|array|)) を配列とするとき、それを要素とす
    る縦ベクトルを返します。

    例:
      V = Algebra.Vector(Integer, 3)
      a = V.new([1, 2, 3])
      a.display
        #=> [1]
        #=> [2]
        #=> [3]

--- Algebra::Vector::vector{|i| ... }
    第 ((|i|)) 成分を ... にしたベクトルを返します。

    例:
      V = Algebra.Vector(Integer, 3)
      a = V.vector{|j| j + 1}
      a.display
        #=> [1]
        #=> [2]
        #=> [3]

--- Algebra::Vector::matrix{|i, j| ... }
    第 ((|i|)) 成分を ... にしたベクトルを返します。
    ((|j|)) には常に 0 が代入されます。

== メソッド:

--- size
    次元を返します。

--- to_a
    各成分を配列にして返します。

--- transpose
    横ベクトル ((<Algebra::Covector>)) に転置します。

--- inner_product(other)
    ((|other|)) との内積を返します。

--- inner_product_complex(other)
    ((|other|)) との内積を返します。
    (({inner_product(other.conjugate)}))と同じです。

--- norm2
    ノルムを返します。
    (({inner_product(self)}))と同じです。

--- norm2_complex
    ノルムを返します。
    (({inner_product(self.conjugate)}))と同じです。

= Algebra::Covector
((*(横ベクトルクラス)*))

ベクトルのクラスです。

== スーパークラス:
* ((|Algebra::MatrixAlgebra|))

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

なし

== 関連する関数:

--- Algebra.Covector(ring, n)
    ((<Algebra::Covector::create>)) (ring n)と同じです。

== クラスメソッド:

--- Algebra::Covector::create(ring, n)
    環 ((|ring|)) を要素とする, ((|n|)) 次元のベクトル（横ベクトル）
    表現するクラスを生成します。

    このメソッドの戻り値は ((<Algebra::Covector>)) クラスのサブクラス
    です。このサブクラスにはクラスメソッドとして ((|ground|)) と
    ((|size|)) が定義され、それぞれ、基底となる環 ((|ring|))、
    サイズ ((|n|)) を返します。

    実際にベクトルを作るにはクラスメソッド ((|new|)),
    ((|matrix|)),
    ((|[]|)) を使います。

    ((<Algebra::Covector>)) は 1 行 ((|n|)) 列の ((<Algebra::MatrixAlgebra>)) と
    同一視されます。

--- Algebra::Covector::new(array)
    ((|array|)) を配列とするとき、それを要素とす
    る横ベクトルを返します。

    例:
      V = Algebra.Covector(Integer, 3)
      a = V.new([1, 2, 3])
      a.display
        #=> [1, 2, 3]

--- Algebra::Covector::covector{|j| ... }
    第 j 成分を ... にしたベクトルを返します。

    例:
      V = Algebra.Covector(Integer, 3)
      a = V.covector{|j| j + 1}
      a.display
        #=> [1, 2, 3]

--- Algebra::Covector::matrix{|i, j| ... }
    第 j 成分を ... にしたベクトルを返します。i には常に 0 が代入されます。

== メソッド:

--- size
    次元を返します。

--- to_a
    各成分を配列にして返します。

--- transpose
    横ベクトル ((<Algebra::Vector>)) に転置します。

--- inner_product(other)
    ((|other|)) との内積を返します。

--- inner_product_complex(other)
    ((|other|)) との内積を返します。
    (({inner_product(other.conjugate)}))と同じです。

--- norm2
    ノルムを返します。
    (({inner_product(self)}))と同じです。

--- norm2_complex
    ノルムを返します。
    (({inner_product(self.conjugate)}))と同じです。

= Algebra::SquareMatrix
((*(正方行列環クラス)*))

正方行列の作る環を表現するクラスです。

== スーパークラス:

* ((|Algebra::MatrixAlgebra|))

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

なし

== 関連する関数:

--- Algebra.SquareMatrix(ring, size)
    ((<Algebra::SquareMatrix::create>))(ring, n) と同じです。

== クラスメソッド:

--- Algebra::SquareMatrix::create(ring, n)

    正方行列表現するクラスを生成します。

    このメソッドの戻り値は
    ((<Algebra::SquareMatrix>)) クラスのサブクラス
    です。このサブクラスにはクラスメソッドとして
    ((|ground|)) と
    ((|size|)) が定義され、それぞれ、基底となる環 ((|ring|))、
    サイズ ((|n|)) を返します。

    SquareMatrix は ((|n|)) 行 ((|n|)) 列の Algebra::MatrixAlgebra と同一視されます。

    実際に行列を作るにはクラスメソッド ((|new|)),
    ((|matrix|)),
    ((|[]|)) を使います。

--- Algebra::SquareMatrix.determinant(aa)
    配列の配列 ((|aa|)) の行列式を返します。

--- Algebra::SquareMatrix.det(aa)
    ((<Algebra::SquareMatrix.determinat>))と同じです。

--- Algebra::SquareMatrix::unity
    単位行列を返します。

--- Algebra::SquareMatrix::zero
    零行列を返します。

--- Algebra::SquareMatrix.const(x)
    成分が ((|x|)) のスカラー行列を返します。

#--- self.regulate(x)

== メソッド
--- size
    サイズを返します。

--- const(x)
    成分が ((|x|)) のスカラー行列を返します。
#--- self.matrices
--- determinant
    行列式を返します。

--- inverse
    逆行列を返します。

--- /(other)
    (({self * other.inverse})) を返します。((|other|)) がスカラーなら
    各要素を ((|other|)) で割ります。

#--- sign(a)
#--- perm

--- char_polynomial(ring)
    ((|ring|)) に多項式環を与えると、特性多項式を返します。

--- char_matrix(ring)
    ((|ring|)) に多項式環を与えると、特性行列を返します。

--- _char_matrix(poly_ring_matrix)
    ((|poly_ring_matrix|)) に多項式成分の行列環を与えると、特性行列を返します。

= Algebra::GaussianElimination
((*(ガウスの消去法モジュール)*))

ガウスの掃き出し法を実現するモジュールです。

== ファイル名:
((|gaussian-elimination.rb|))

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

なし

== クラスメソッド:

なし

== メソッド

--- swap_r!(i, j)
    ((|i|)) 行と ((|j|)) 行を入れ換えます。

--- swap_r(i, j)
    ((|i|)) 行と ((|j|)) 行を入れ換えたものを返します。

--- swap_c!(i, j)
    ((|i|)) 列と ((|j|)) 列を入れ換えます。

--- swap_c(i, j)
    ((|i|)) 列と ((|j|)) 列を入れ換えたものを返します。

--- multiply_r!(i, c)
    ((|i|)) 行目を ((|c|)) 倍します。

--- multiply_r(i, c)
    ((|i|)) 行目を ((|c|)) 倍したものを返します。

--- multiply_c!(j, c)
    ((|j|)) 列目を ((|c|)) 倍します。

--- multiply_c(j, c)
    ((|j|)) 列目を ((|c|)) 倍したものを返します。

--- divide_r!(i, c)
    ((|i|)) 行目を ((|c|)) で割ります。

--- divide_r(i, c)
    ((|i|)) 行目を ((|c|)) 割ったものを返します。

--- divide_c!(j, c)
    ((|j|)) 列目を ((|c|)) で割ります。

--- divide_c(j, c)
    ((|j|)) 列目を ((|c|)) 割ったものを返します。

--- mix_r!(i, j, c)
    ((|i|)) 行目に ((|j|)) 行目の ((|c|)) 倍を足します。

--- mix_r(i, j, c)
    ((|i|)) 行目に ((|j|)) 行目の ((|c|)) 倍を足したものを返します。

--- mix_c!(i, j, c)
    ((|i|)) 列目に ((|j|)) 列目の ((|c|)) 倍を足します。

--- mix_c(i, j, c)
    ((|i|)) 列目に ((|j|)) 列目の ((|c|)) 倍を足したものを返します。

--- left_eliminate!
    左からの基本変形で階段行列に変形します。

    戻り値は、変形するのに使った正方行列の積とその正方行列の
    行列式と階数の配列です。

    例:
      require "matrix-algebra"
      require "mathn"
      class Rational < Numeric
        def inspect; to_s; end
      end
      M = Algebra.MatrixAlgebra(Rational, 4, 3)
      a = M.matrix{|i, j| i*10 + j}
      b = a.dup
      c, d, e = b.left_eliminate!
      b.display #=> [1, 0, -1]
                #=> [0, 1, 2]
                #=> [0, 0, 0]
                #=> [0, 0, 0]
      c.display #=> [-11/10, 1/10, 0, 0]
                #=> [1, 0, 0, 0]
                #=> [1, -2, 1, 0]
                #=> [2, -3, 0, 1]
      p c*a == b#=> true
      p d       #=> 1/10
      p e       #=> 2

--- left_inverse
    左からの基本変形による一般逆行列です。

--- left_sweep
    左からの基本変形で階段行列にして返します。

--- step_matrix?
    階段行列であるとき、軸(pivot)の配列を返します。そうでないとき、nil
    を返します。

--- kernel_basis
    右から掛けて零になるベクトルの空間の基底の配列を返します。
    各基底は ((<Algebra::Vector>)) の要素です。

    例:
      require "matrix-algebra"
      require "mathn"
      M = Algebra.MatrixAlgebra(Rational, 5, 4)
      a = M.matrix{|i, j| i + j}
      a.display #=>
        #[0, 1, 2, 3]
        #[1, 2, 3, 4]
        #[2, 3, 4, 5]
        #[3, 4, 5, 6]
        #[4, 5, 6, 7]
      a.kernel_basis.each do |v|
        puts "a * #{v} = #{a * v}"
          #=> a * [1, -2, 1, 0] = [0, 0, 0, 0, 0]
          #=> a * [2, -3, 0, 1] = [0, 0, 0, 0, 0]
      end

--- determinant_by_elimination
    体上の正方行列の行列式を掃き出し法で求めます。

=end


#' Singular Value Decomposition
#'
#' TODO
#'
#' @details
#' TODO
#'
#' @param x
#' numeric distributed matrix
#' @param nu
#' number of left singular vectors to return when calculating singular values.
#' @param nv
#' number of right singular vectors to return when calculating singular values.
#'
#' @return
#' TODO
#'
#' @export
ksvd = function(x,  nu = min(m, n), nv = min(m, n))
{
  m = nrow(x)
  n = ncol(x)
  min_mn = min(m, n)

  if (m < n)
    comm.stop("only m>=n is supported in ksvd()")

  ICTXT = x@ICTXT
  bldim = x@bldim
  if (bldim[1] != bldim[2])
    comm.stop(paste0("ksvd() requires a square blocking factor; have ", bldim[1L], "x", bldim[2L]))

  dim_a = dim(x)
  ldim_a = base.numroc(dim=dim_a, bldim=bldim, ICTXT=ICTXT)
  desca = base.descinit(dim_a, bldim, ldim_a, ICTXT)

  dim_u = c(m, min_mn)
  if (nu == 0)
  {
    jobu = 'N'
    ldim_u = c(-1L, -1L)
  }
  else
  {
    jobu = 'V'
    ldim_u = base.numroc(dim=dim_u, bldim=bldim, ICTXT=ICTXT)
  }

  dim_vt = c(min_mn, n)
  if (nv == 0)
  {
    jobvt = 'N'
    ldim_vt = c(-1L, -1L)
  }
  else
  {
    jobvt = 'V'
    ldim_vt = base.numroc(dim=dim_vt, bldim=bldim, ICTXT=ICTXT)
  }

  descu = base.descinit(dim_u, bldim, ldim_u, ICTXT)
  descvt = base.descinit(dim_vt, bldim, ldim_vt, ICTXT)

  # eigtype: "r", "d"
  out = rpdgeqsvd(jobu, jobvt, eigtype='d', x@Data, desca, descu, descvt)

  if (nu > 0)
  {
    u = new("ddmatrix", Data=out$u, dim=dim_u, ldim=ldim_u, bldim=bldim, ICTXT=ICTXT)
    if (nu < u@dim[2L])
      u = u[, 1L:nu]
  }
  else
    u = NULL

  if (nv > 0)
  {
    vt = new("ddmatrix", Data=out$vt, dim=dim_vt, ldim=ldim_vt, bldim=bldim, ICTXT=ICTXT)
    if (nv < vt@dim[1L])
      vt = vt[1L:nv, ]
  }
  else
    vt = NULL

  ret = list(d=out$s)
  ret$u = u
  ret$vt = vt

  ret
}


##### 医学統計勉強会18第五回比率と分割表　R code #####

## Low Infant Birth Data ##

# birthwt2 の準備 #
library(MASS)
data(birthwt)
head(birthwt, n=2)

birthwt2 <- birthwt[, -10]		# bwt: 出生体重を除く
birthwt2$race <- factor(birthwt2$race, label=c("white", "black", "other"))	# 因子型に変換し、水準のラベルを1, 2, 3から、white, black, otherに変更する。
birthwt2$ptl[birthwt2$ptl >= 1] <- "1+"		# ptl: 1以上の値を "1+" とする。
birthwt2$ftv[birthwt2$ftv >= 1] <- "1+"		# ftv: 1以上の値を "1+" とする。
head(birthwt2, n=2)

attach(birthwt2)	# birthwt2に含まれる変数を、個別に扱えるようにする。

# 度数と相対度数 #
tbl <- table(race)	# 度数 #
tbl

prop.table(tbl)		# 相対度数 #

## event rate (person-time) : confidence interval and hypothesis testing ##

library(epitools)

##Examples from Rothman 1998, p. 238
bc <- c(Unexposed = 15, Exposed = 41)
pyears <- c(Unexposed = 19017, Exposed = 28010)
dd <- matrix(c(41,15,28010,19017),2,2)
dimnames(dd) <- list(Exposure=c("Yes","No"), Outcome=c("BC","PYears"))
dd

pois.exact(15,19117)
pois.exact(41,28010)

rateratio.wald(dd)

## Test of Proportion : proportions test with continuity correction
prop.test(96, 189, p=0.6)

## Test of Equal or Given Proportion : Clopper-Pearson exact confidence interval ##

binom.test(0, 10)

## 分割表：正答率、感度、特異度、陽性的中率、陰性的中率 ##

table(low, smoke)

library(pROC)

tbl.coords <- roc(low, smoke)

coords(tbl.coords, x="best", ret=c("accuracy", "1-sensitivity", "sensitivity",
"1-specificity", "specificity", "ppv", "npv"))

## ROC曲線とAUC ##

library(pROC)

x <- c(1,0,0,0,0,0,0,0,0,0,0,0,1,1,1,1,1,1,0,0,0,0,0,0,0,0,0,0,0,1,1,1,1,1,1,1,1,1,1,1,0,0,0,0,0,0,0,0,1,1,1,1,1,1,1,1,1,1,1,1)		# 疾患あり:1，疾患なし:0
y <- c(0,0,0,0,0,0,0,0,0,0,1,1,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,3,3,3,3,3,3,3,3,3,3,3,3,3,3,3,3,3,3,3,4,4,4,4,4,4,4,4,4,4,4,4)		# 検査数値
tbl <- table(x, y)
tbl

y2 <- rep((0:5), each=10)
tbl2 <- table(x, y2)
tbl2

tbl.roc <- roc(x, y)
plot(tbl.roc, print.auc=TRUE, print.thres=TRUE)				# ROC曲線の描画
opt.sp <- tbl.roc$sp[which.max(tbl.roc$se+tbl.roc$sp)]		# 最適な特異度
opt.se <- tbl.roc$se[which.max(tbl.roc$se+tbl.roc$sp)]		# 最適な感度
abline((opt.sp+opt.se), -1)		# 最適なカットポイントを通る45度線

tbl.roc2 <- roc(x, y2)
roc.test(tbl.roc, tbl.roc2)		# Compare the AUC of two ROC curves

### Fisherの直接法とχ二乗検定 ###

tbl <- matrix(c(405, 173, 416, 152),
				nrow=2,
				dimnames=list("β-Blocker" = c("(+)", "(-)"),
							  "Olmesartan" = c("(+)", "(-)")))
tbl
fisher.test(tbl)				# Fisherの直接法
chisq.test(tbl)					# カイ二乗検定（連続補正あり）
chisq.test(tbl, correct=FALSE)	# カイ二乗検定（連続補正なし）

### McNemar検定 ###

tbl2 <- matrix(c(175, 54, 16, 188),
				nrow=2,
				dimnames=list("2004 election" = c("Democrat", "Repablican"),
							  "2008 election" = c("Democrat", "Repablican")))
tbl2
binom.test(16, (16 + 54))	# 二項分布による正確検定
mcnemar.test(tbl2)			# McNemar検定（連続補正あり）
mcnemar.test(tbl2)			# McNemar検定（連続補正なし）

### Mantel-Haenszel検定 ###

tbl3 <- array(c(80,160,16,160, 50, 10, 452, 452), dim=c(2,2,2))
tbl3
mantelhaen.test(tbl3)

### Cochran-Armitage Trend Test ###

tbl4 <- matrix(c(17066, 14464, 788, 126, 37, 48, 38, 5, 1, 1),
				nrow=2, byrow=TRUE,
				dimnames=list("Malformation" = c("Absent", "Present"),
							  "Alcohol Consumption" = c("0", "< 1", "1-2", "3-5", ">= 6")))
tbl4
event <- tbl4[2, ]
total <- apply(tbl4, 2, sum)
prop.trend.test(event, total, score=c(0, 0.5, 1.5, 4.0, 7.0))		# Cochran-Armitage Trend Test
prop.test(event, total)				# （傾向無しの）独立性の検定


### R script to demonstrate Random Fourier Features version of latent Gaussian Process model for quasar time delay estimation
#install_tensorflow(extra_packages = "tensorflow-probability")

library(tensorflow)
#Sys.setenv(TENSORFLOW_PYTHON="/Users/jburgess/.environs/tflow/bin/python3")
Sys.setenv("CUDA_VISIBLE_DEVICES" = -1) # temporary fix to avoid bug in Greta concerning GPU computations
#use_python("/Users/jburgess/.environs/tflow/bin/python3")
use_virtualenv("/Users/jburgess/.environs/tflow")
library(greta)
#Sys.setenv(TENSORFLOW_PYTHON="/Users/jburgess/.environs/tflow/bin/python3")
### Define imagined data generating process and draw a mock dataset
###
### In this toy model there are two lensed images of the quasar observed at different times over a 50 day window
### Each image has time-series of brightness, one being offset by a fixed delay from the other
### The brightness time-series is modelled as an exponentiated Gaussian process modulating the average brightness of each quasar image

Nobs_quasar_image_A <- 150
observation_times_quasar_image_A <- sort(runif(Nobs_quasar_image_A,0,50))
Nobs_quasar_image_B <- 75
observation_times_quasar_image_B <- sort(runif(Nobs_quasar_image_B,0,50))

true_time_delay <- 1
true_GP_bandwidth <- 1
true_GP_scale <- 0.5
true_expected_counts_quasar_image_A <- 40
true_expected_counts_quasar_image_B <- 30
true_expected_background_counts <- 5

true_cov_matrix <- true_GP_scale^2*exp(-true_GP_bandwidth*as.matrix(dist(sort(c(observation_times_quasar_image_A,observation_times_quasar_image_B+true_time_delay)),upper = TRUE,diag = TRUE))^2)
true_cov_matrix <- true_cov_matrix+diag(Nobs_quasar_image_A+Nobs_quasar_image_B)*0.0001

library(MASS)
true_latent_curve <- exp(mvrnorm(1,rep(0,Nobs_quasar_image_A+Nobs_quasar_image_B),true_cov_matrix))

true_latent_curve_quasar_image_A <- true_latent_curve[which(sort.list(c(observation_times_quasar_image_A,observation_times_quasar_image_B+true_time_delay)) %in% 1:(Nobs_quasar_image_A))]
true_latent_curve_quasar_image_B <- true_latent_curve[which(!(sort.list(c(observation_times_quasar_image_A,observation_times_quasar_image_B+true_time_delay)) %in% 1:(Nobs_quasar_image_A)))]
observed_counts_quasar_image_A <- rpois(Nobs_quasar_image_A,true_expected_background_counts+true_expected_counts_quasar_image_A*true_latent_curve_quasar_image_A)
observed_counts_quasar_image_B <- rpois(Nobs_quasar_image_B,true_expected_background_counts+true_expected_counts_quasar_image_B*true_latent_curve_quasar_image_B)

layout(1:2)
plot(observation_times_quasar_image_A,observed_counts_quasar_image_A,ylim=c(0,150))
title("Mock Dataset: Image A")
plot(observation_times_quasar_image_B,observed_counts_quasar_image_B,ylim=c(0,150))
title("Mock Dataset: Image B")

### Construct Bayesian model with RFF approximation of latent Gaussian process and sample with Greta (HMC)
###
### The Bayesian model mimics the mock data generating process with the parameters assigned sensible priors, close to their true values
### The implementation of the Gaussian process is by way of the RFF approximation: https://people.eecs.berkeley.edu/~brecht/papers/07.rah.rec.nips.pdf
### Not implemented here: RFFs are easily extensible to represent non-stationary Gaussian processes: https://www.sciencedirect.com/science/article/pii/S2211675317302890
### The RFF code here uses a low discrepancy sequence (Quasi-Monte Carlo, rather than completely random), and works with sin/cos pairs (rather than random phases), since these have been shown to perform well
###
### The beauty of the greta package is that you can write your model mostly using base R commands and it will built a graph in tensorflow automatically for you to provide fast HMC

library(randtoolbox)

k_RFF <- 500 # Number of RFF bases (will use sin&cos orthogonal pairs)
omega_qmc_RFF <- t(qnorm(halton(k_RFF,1)))

time_delay <- normal(0,1)
log_GP_bandwidth <- normal(0,1)
log_GP_scale <- normal(0,1)
log_expected_counts_quasar_image_A <- normal(log(50),2)
log_expected_counts_quasar_image_B <- normal(log(50),2)
log_expected_background_counts <- normal(log(5),2)
RFF_slopes <- normal(rep(0,k_RFF*2),1)

GP_bandwidth <- exp(log_GP_bandwidth)
GP_scale <- exp(log_GP_bandwidth)
expected_background_counts <- exp(log_expected_background_counts)

omega_QMC_RFF_scaled <- omega_qmc_RFF*GP_bandwidth
RFFprojections_A <- observation_times_quasar_image_A%*%omega_QMC_RFF_scaled
RFFprojections_B <-  (observation_times_quasar_image_B+time_delay)%*%omega_QMC_RFF_scaled
RFFs_A <- cbind(sin(RFFprojections_A),cos(RFFprojections_A))
RFFs_B <- cbind(sin(RFFprojections_B),cos(RFFprojections_B))
latent_GP_A <- (RFFs_A%*%RFF_slopes)*GP_scale/sqrt(k_RFF)
latent_GP_B <- (RFFs_B%*%RFF_slopes)*GP_scale/sqrt(k_RFF)

latent_signal_A <- exp(latent_GP_A+log_expected_counts_quasar_image_A)
latent_signal_B <- exp(latent_GP_B+log_expected_counts_quasar_image_B)
obs_signal_A <- latent_signal_A+expected_background_counts
obs_signal_B <- latent_signal_B+expected_background_counts

distribution(observed_counts_quasar_image_A) <- poisson(obs_signal_A)
distribution(observed_counts_quasar_image_B) <- poisson(obs_signal_B)

m <- model(time_delay,log_GP_bandwidth,log_GP_scale,log_expected_counts_quasar_image_A,log_expected_counts_quasar_image_B,log_expected_background_counts,RFF_slopes)

optim <- opt(m,max_iterations = 100) ## Take a few simple optimising steps to get towards the bulk of posterior mass before starting HMC

draws <- mcmc(m,n_samples = as.integer(1000),chains=as.integer(1)) ## Single chain here: there are obvious benefits to running multiple chains for a proper analysis

posterior.latent.GP_A <- matrix(0,nrow=25,ncol=(Nobs_quasar_image_A+Nobs_quasar_image_B))
posterior.latent.GP_B <- matrix(0,nrow=25,ncol=(Nobs_quasar_image_A+Nobs_quasar_image_B))
posterior.relative_observation_times_to_A <- matrix(0,nrow=25,ncol=(Nobs_quasar_image_A+Nobs_quasar_image_B))
posterior.relative_observation_times_to_B <- matrix(0,nrow=25,ncol=(Nobs_quasar_image_A+Nobs_quasar_image_B))
for (i in 1:25) {
  drawn.par <- list(
    'time_delay'=draws[[1]][i*10,1],
    'log_GP_bandwidth'=draws[[1]][i*10,2],
    'log_GP_scale'=draws[[1]][i*10,3],
    'log_expected_counts_quasar_image_A'=draws[[1]][i*10,4],
    'log_expected_counts_quasar_image_B'=draws[[1]][i*10,5],
    'log_expected_background_counts'=draws[[1]][i*10,6],
    'RFF_slopes'=draws[[1]][i*10,7:(k_RFF*2+7-1)]
  )
  posterior.latent.GP_A[i,] <- as.numeric(calculate(exp(c(latent_GP_A,latent_GP_B)+log_expected_counts_quasar_image_A)+expected_background_counts,values=drawn.par))
  posterior.latent.GP_B[i,] <- as.numeric(calculate(exp(c(latent_GP_A,latent_GP_B)+log_expected_counts_quasar_image_B)+expected_background_counts,values=drawn.par))
  posterior.relative_observation_times_to_A[i,] <-  c(observation_times_quasar_image_A,observation_times_quasar_image_B+drawn.par$time_delay)
  posterior.relative_observation_times_to_B[i,] <-  c(observation_times_quasar_image_A-drawn.par$time_delay,observation_times_quasar_image_B)
  cat(i,"\n")
}

layout(1:2)
plot(observation_times_quasar_image_A,observed_counts_quasar_image_A,xlim=c(0,50),ylim=c(0,125),xlab='Observation Times A',ylab="Observed Counts A")
for (i in 1:25) {lines(sort(relative_obs_times_to_A),posterior.latent.GP_A[i,sort.list(relative_obs_times_to_A)],col=hsv(i/25*0.6,alpha=0.1))}
title("Posterior Draws of Latent Mean Signal: Image A")

plot(observation_times_quasar_image_B,observed_counts_quasar_image_B,xlim=c(0,50),ylim=c(0,125),xlab='Observation Times B',ylab="Observed Counts B")
for (i in 1:25) {lines(sort(relative_obs_times_to_B),posterior.latent.GP_B[i,sort.list(relative_obs_times_to_B)],col=hsv(i/25*0.6,alpha=0.1))}
title("Posterior Draws of Latent Mean Signal: Image B")

layout(1)
hist(draws[[1]][1,],xlab="",ylab="Freq. in Posterior Samples",)


# 4. faza: Analiza podatkov

library(mgcv)
library(forecast)

DODANAVREDNOST <- DODANAVRED[seq(1, 468, 36), "SLOVENIJA"]
PREBIVALSTVO <- prebivalstvo[(41:53),"Prebivalstvo"]
P <- data.frame(X=DODANAVREDNOST, Y=PREBIVALSTVO)
# plot(DODANAVREDNOST ~ PREBIVALSTVO)
# lm <- lm(X ~ Y, data = P)
# summary(lm)
# predict(lm)
# plot(predict(lm))
# lines(DODANAVREDNOST, PREBIVALSTVO, col="red", lwd=10)

#leta 2008 največji BDP,po letu 2008 kljub rasti prebivalstva BDP začne padati(gospodarska kriza)
attach(P)
pdf("slike/prebBDP.pdf")
plot(DODANAVREDNOST, PREBIVALSTVO, pch=20, col="blue")

mgam <- gam(Y ~ s(X), data = P)
curve(predict(mgam, data.frame(X=x)), add = TRUE, col = "red")

dev.off()
detach(P)

#napoved  BDP
pdf("slike/napovedBDP.pdf")
leto <- DODANAVRED[seq(1, 468, 36),"Leto"]
BL <- data.frame(X=leto,Y=DODANAVREDNOST)
bdpts <- ts(data=BL$Y, start=c(2000,1)) # časovni vektor
plot(forecast(bdpts), main="Napoved BDP", ylim=c(0,50000), ylab="Dodana vrednost", xlab="Leto")
dev.off()

#napoved prebivalstva
pdf("slike/napovedPREBIVALSTVA.pdf")
D <- data.frame(prebivalstvo)
prebts <- ts(data=D$Prebivalstvo, start=c(1960,1))
plot(forecast(prebts), main="Napoved prebivalstva", xlab="Leto", ylab="število prebivalcev")
dev.off()

#Stolpični graf primerjava deleža prebivalstva in deleža BDP
prebivalcireg <-PREBIVALSTVOREGIJE[,"Število.prebivalcev"]
DEJ <- as.integer(as.table(matrix(DODANAVRED[445, c(6:9, 11:18)])))
# DEJ1 <- DEJ[order(DEJ)]
# prebivalcireg1 <- prebivalcireg[c(5 ,8, 10,  7, 12,  1,  2,  6,  3,  9, 11,  4)]
o <- order(DEJ)
DEJ1 <- DEJ[o]
prebivalcireg1 <- prebivalcireg[o]

pdf("slike/delez2.pdf")
prebdej <- matrix(c(prebivalcireg1, DEJ1), nrow=2, byrow=TRUE)
barplot(prebdej, sub= "Regije", ylab="Vrednost",
        main= "Primerjava deleža BDP in prebivalcev po regijah",
        col=c("blue", " green"), width=3, beside=TRUE,
        names.arg=PREBIVALSTVOREGIJE[o,"Regije"], las = 2, cex.names = 0.4)
legend("topleft", legend = c("delež prebivalstva", "delež BDP"),
       fill = c("blue", "green"))
dev.off()

#graf povezave BDP in dolga po letih
dolg <- DOLG[(1:13), "Dolg"] #vrednost dolga

pdf("slike/dolg2.pdf")

range1 <- range(0, dolg, DODANAVREDNOST)
plot(DODANAVREDNOST, type="o", col="red",ylim=range1, axes=FALSE, ann=FALSE)
axis(1, at=1:13, lab=c("2000" ,"2001", "2002", "2003", "2004", "2005", "2006", "2007", "2008", "2009", "2010",
                       "2011", "2012"))
axis(2, at=10000*0:range1[2])
box()
lines(dolg, type="o", pch=22, col="blue", lty=2)
title(main="Primerjava vrednosti BDP in dolga po letih")
title(xlab="Leta")
title(ylab="vrednost")
legend("topleft", c("Vrednost BDP","vrednost dolga"), cex=0.8,
       col=c("red","blue"), lty=1:2)

dev.off()


# Josep Ll. Berral-García
# ALOJA-BSC-MSR aloja.bsc.es
# 2016-02-20
# Implementation of Quadratic (or Linear) Regression Tree method recursive-partition-like

# Usage:
#	mtree <- qrt.tree(varout = target.name, dataset = dataframe, simple = 0);
#	prediction <- qrt.predict(model = mtree, newdata = dataframe);
#	qrt.plot.tree(mtree);

suppressMessages(library(rpart));	# Recursive Partition Trees

###############################################################################
# Regression Tree M5-Prediction-like with Linear/Quadratic Regression         #
###############################################################################

qrt.tree <- function (varout, dataset, m = 30, cp = 0.001, simple = 1)
{
	if (!is.numeric(m)) m <- as.numeric(m);
	if (!is.numeric(cp)) cp <- as.numeric(cp);
	if (!is.numeric(simple)) simple <- as.numeric(simple);

	vout <- varout;
	vin <- colnames(dataset)[(!colnames(dataset) %in% vout)];
	dataset <- dataset[,c(vout,vin)];

	fit <- rpart(formula=dataset[,vout]~.,data=dataset[,vin],method="anova",control=rpart.control(minsplit=as.integer(m),cp=as.numeric(cp)));
	nodes <- as.numeric(rownames(fit$frame));

	err_branch <- regs <- preds <- list();
	indexes <- NULL;
	mae <- rae <- 0;
	for (i in unique(fit$where))
	{
		daux <- dataset[fit$where==i,c(vout,vin)];
		j <- nodes[i];

		if (simple > 0) regs[[j]] <- lm(formula=daux[,vout] ~ ., data=data.frame(daux[,vin]));
		if (simple <= 0) regs[[j]] <- lm(formula=daux[,vout] ~ . + (.)^2, data=data.frame(daux[,vin]));
		indexes <- c(indexes,j);

		preds[[j]] <- regs[[j]]$fitted.values;
		err_branch[[j]] <- paste(j,nrow(daux),mean(abs(preds[[j]] - daux[,vout])),mean(abs((preds[[j]] - daux[,vout])/daux[,vout])),sep=" ");
	}

	retval <- list();
	retval[["rpart"]] <- fit;
	retval[["regs"]] <- regs;
	retval[["indexes"]] <- indexes;

	err_data <- data.frame(strsplit(unlist(err_branch)," "));
	err_data <- apply(err_data, 1, function(x) as.numeric(x));
	auxid <- if (is.null(nrow(err_data))) 1 else err_data[,1];
	err_data <- if (is.null(nrow(err_data))) t(data.frame(err_data[-1])) else data.frame(err_data[,-1]);
	colnames(err_data) <- c("Instances","MAE","MAPE");
	rownames(err_data) <- auxid;
	retval[["error_branch"]] <- err_data;

	preds <- unlist(preds);
	retval[["fitted.values"]] <- preds[order(as.integer(names(preds)))];
	retval[["mae"]] <- mean(abs(retval$fitted.values - dataset[,vout]));
	retval[["rae"]] <- mean(abs((retval$fitted.values - dataset[,vout])/dataset[,vout]));

	class(retval) <- c(class(retval),"qrt");

	retval;
}

qrt.predict <- function (model, newdata)
{
	colnames(newdata) <- gsub(" ",".",colnames(newdata));

	fit_node <- model$rpart;
	fit_node$frame$yval <- as.numeric(rownames(fit_node$frame));

	sapply(1:nrow(newdata), function(i) {
		node <- as.numeric(predict(fit_node,newdata[i,]));
		pred <- as.numeric(predict(model$regs[[node]],newdata[i,]));
		pred;
	});
}

qrt.plot.tree <- function (model, uniform = TRUE, main = "Classification Tree", use.n = FALSE, all = FALSE)
{
	fit_node <- model$rpart;
	fit_node$frame$yval <- as.numeric(rownames(fit_node$frame));

	plot(fit_node,uniform=uniform,main=main);
	text(fit_node, use.n=use.n, all=all, cex=.8);
}

qrt.regressions <- function (model)
{
	retval <- list()
	for (i in sort(model$index)) retval[[paste("Reg-",i,sep="")]] <- model$regs[[i]]$coefficients[!is.na(model$regs[[i]]$coefficients)];
	retval;
}

qrt.regression.coefficients <- function (model, index)
{
	model$regs[[index]]$coefficients[!is.na(model$regs[[index]]$coefficients)];
}

qrt.regression.model <- function (model, index)
{
	model$regs[[index]]$model;
}

qrt.json <- function (model)
{
	faux <- model$rpart$frame;
	saux <- model$rpart$splits;
	spointer <- 1;

	jaux <- '';
	raux <- c(rownames(faux),1);

	for (i in 1:nrow(faux))
	{
		if (faux$var[i] == "<leaf>")
		{
			caux <- t(model$regs[[as.numeric(raux[i])]]$coefficients);
			eaux <- model$error_branch[raux[i],];
			laux <- '';
			for (j in 1:length(caux)) laux <- paste(laux,',"',colnames(caux)[j],'":"',caux[j],'"',sep="");
			laux <- paste('regression:{',substring(laux,2),'},mae:',eaux$MAE,',mape:',eaux$MAPE,sep="");

			jaux <- paste(jaux,'{text:{name:"',faux$var[i],'",desc:"',faux$n[i],':',faux$yval[i],'"},leaf:',raux[i],',n:',faux$n[i],',yval:',faux$yval[i],',',laux,'}',sep="");
			if (as.numeric(raux[i]) > as.numeric(raux[i+1]))
			{
				curr_level <- ceil(log(as.numeric(raux[i])+1)/log(2));
				next_level <- ceil(log(as.numeric(raux[i+1])+1)/log(2));
				for (j in 1:(curr_level - next_level)) jaux <- paste(jaux,']}',sep="");
			}
			if (i < nrow(faux)) jaux <- paste(jaux,',',sep="");
		}
		else
		{
			split <- saux[spointer,"index"];
			ineq <- saux[spointer,"ncat"];
			relation <- if (ineq == 1) paste('>=',split,sep="") else paste('<',split,sep="");
			spointer <- spointer + faux$ncompete[i] + faux$nsurrogate[i] + 1;

			jaux <- paste(jaux,'{text:{name: "',faux$var[i],relation,'",desc:"',faux$n[i],':',faux$yval[i],'"},var:"',faux$var[i],'",relation:',ineq,',split:',split,',leaf:',raux[i],',n:',faux$n[i],',yval:',faux$yval[i],',children:[',sep="");
		}
	}

	jaux;
}

###############################################################################
# Fine-tunning parameters for QRT                                             #
###############################################################################

qrt.select <- function (vout, vin, traux, tvaux, mintervals, quiet = 1, simple = 1, ...)
{
	trmae <- NULL;
	tvmae <- NULL;
	mmin <- 0;
	mminmae <- 9e+15;
	off_threshold <- 1e-4;
	for (i in mintervals)
	{
		ml <- qrt.tree(varout=vout,dataset=data.frame(traux[,c(vout,vin)]),m=i,simple=simple);
		trmae <- c(trmae, ml$mae);

		prediction <- qrt.predict(model=ml,newdata=data.frame(tvaux[,c(vout,vin)]));

		mae <- mean(abs(prediction - tvaux[,vout]));
		tvmae <- c(tvmae,mae);

		if (mae < mminmae - off_threshold) { mmin <- i; mminmae <- mae; }
		if (quiet == 0) print(paste("[INFO]",i,mae,mmin,mminmae));
	}
	if (quiet == 0) print (paste("Selected M:",mmin));

	retval <- list();
	retval[["trmae"]] <- trmae;
	retval[["tvmae"]] <- tvmae;
	retval[["mmin"]] <- mmin;
	retval[["mintervals"]] <- mintervals;

	retval;
}


#' matmult
#'
#' Matrix multiplication for numeric/float matrices.
#'
#' @details
#' If a numeric matrix is multiplied against a float matrix, then if the
#' "numeric" matrix is integers, the integers are promoted to floats. Otherwise,
#' the float matrix is promoted to doubles.
#'
#' @param x,y
#' Numeric/float matrices.
#'
#' @return
#' A matrix of the same type as the highest precision input.
#'
#' @examples
#' library(float)
#'
#' s1 = flrunif(5, 5)
#' s2 = flrunif(5, 2)
#' x = matrix(1:25, 5)
#'
#' s1 %*% s2 # float
#'
#' storage.mode(x) # integer
#' x %*% s2 # float
#'
#' storage.mode(x) = "double"
#' x %*% s2 # double
#'
#' @useDynLib float R_matmult_spm
#' @name matmult
#' @rdname matmult
NULL

mm_float32 = function(x, y)
{
  ret = .Call(R_matmult_spm, DATA(x), DATA(y))
  float32(ret)
}

mm_float32_mat = function(x, y)
{
  if (is.integer(y))
    x %*% fl(y)
  else if (is.double(y))
    dbl(x) %*% y
  else
    stop("requires numeric/complex matrix/vector arguments")
}

mm_mat_float32 = function(x, y)
{
  if (is.integer(x))
    fl(x) %*% y
  else if (is.double(x))
    x %*% dbl(y)
  else
    stop("requires numeric/complex matrix/vector arguments")
}

#' @rdname matmult
#' @export
setMethod("%*%", signature(x="float32", y="float32"), mm_float32)

#' @rdname matmult
#' @export
setMethod("%*%", signature(x="float32", y="matrix"), mm_float32_mat)

#' @rdname matmult
#' @export
setMethod("%*%", signature(x="matrix", y="float32"), mm_mat_float32)


# Script about parental age influence
library(RColorBrewer)

# Import and format data:
data_mut <- read.csv("mutation_rate.txt", sep =" ", header=FALSE) # mutation_rate.txt is obtained during the detection of de novo mutation
age_father=read.csv("male_age.txt", sep =" ", header=FALSE) # one column with father age
age_mother=read.csv("female_age.txt", sep =" ", header=FALSE) # one column with mother age
fa=read.csv("father.txt", sep =" ", header=FALSE) # one column with father ID
mo=read.csv("mother.txt", sep =" ", header=FALSE) # one column with mother age
data=cbind(data_mut[,1:2],age_father, age_mother, fa, mo)

# Parental correlation on mutation rate ######
# Simple correlation:

# Linear model for both age
fit <- lm(data[,2] ~ data[,3] + data[,4], data=data)
summary(fit)

# Predict mu with this model
mu_list=vector()
for(i in seq(1,nrow(data))){
    mu = 1.355e-09+(4.588e-10*data[i,3])+(7.936e-11*data[i,4])
    mu_list=c(mu_list, mu)
}
cor.test(mu_list, data[,2], method="pearson")

fit <- lm(data[,2] ~ mu_list)
summary(fit) # show results

png("model.png", width = 1300, height = 850)
par(mar=c(10,15,4,2), mgp=c(3, 3, 0))
plot(mu_list, data[,2], pch=19, xlab="", ylab="", xlim=c(4e-9,1.2e-8), ylim=c(4e-9,1.2e-8),cex=3, cex.lab=2.5, cex.axis=2.5, xaxt="n", yaxt="n")
axis(1, at=c(4.0e-09, 5.0e-09, 6.0e-09, 7.0e-09, 8.0e-09, 9.0e-09, 1.0e-08, 1.1e-08, 1.2e-08),label=c("0.4","0.5","0.6", "0.7", "0.8","0.9","1.0","1.1","1.2"), cex.axis=4)
axis(2, at=c(4.0e-09, 5.0e-09, 6.0e-09, 7.0e-09, 8.0e-09, 9.0e-09, 1.0e-08, 1.1e-08, 1.2e-08),label=c("0.4","0.5","0.6", "0.7", "0.8","0.9","1.0","1.1","1.2"),cex.axis=4, las=2)
mtext(expression("Expected mutation rate x 10"^-8), 1, line=8, cex=3.5)
mtext(expression("Observed mutation rate x 10"^-8), 2, line=9, cex=3.5)
abline(3.765e-13,1.000e+00, lty=2, lwd=3, col="grey40")
text(c(1.15e-08,1.155e-08), c(0.9e-08, 0.95e-08), labels = c("r = 0.54", "p = 0.016"), font=2, cex=3.5)
text(1.00e-8, 1.18e-8, expression(paste(mu, " = 1.36e"^-9, "+ 7.94e"^-11, "× a"[mat], "+ 4.59e"^-10, "× a"[pat])), font=2, cex=2)
dev.off()

# Father correlation ##################################################

linearMod_father <- lm(data[,2] ~ data[,3], data=data)
summary(linearMod_father)
## confidence interval with predict
a <- data[,3]
m <- data[,2]
linearMod_father <- lm(m ~ a)
newx = seq(4,17,by = 0.5)
conf_interval <- predict(linearMod_father, newdata=data.frame(a=newx), interval="confidence",level = 0.95)

png("father_age_pred.png", width = 1300, height = 850)
par(mar=c(9,23,4,2), mgp=c(3, 3, 0))
plot(data[,3], data[,2], pch=19, xlab="", ylab="", xlim=c(3,16), cex=3, cex.lab=2.5, cex.axis=2.5, col="blue", xaxt="n", yaxt="n")
bluetrans <- rgb(204, 229, 255, 255, maxColorValue=255)
polygon(c(newx, rev(newx)), c(conf_interval[,2], rev(conf_interval[,3])),
     col = bluetrans, border = NA)
points(data[,3], data[,2], pch=19, cex=3, cex.lab=2.5, cex.axis=2.5, col="blue")
abline(1.022e-09, 5.393e-10, lwd=3, lty=2, col="darkblue")
axis(1, cex.axis=4)
axis(2, at=c(4.0e-09, 5.0e-09, 6.0e-09, 7.0e-09, 8.0e-09, 9.0e-09, 1.0e-08, 1.1e-08),label=c(expression("0.4 x 10"^-8), expression("0.5 x 10"^-8), expression("0.6 x 10"^-8), expression("0.7 x 10"^-8), expression("0.8 x 10"^-8), expression("0.9 x 10"^-8), expression("1.0 x 10"^-8), expression("1.1 x 10"^-8)),cex.axis=4, las=2)
mtext("Paternal age", 1, line=7, cex=4.5)
mtext("Mutation rate (per generation)", 2, line=20, cex=4.5)
text(c(4.1,4.6), c(1.12e-08, 1.06e-08), labels = c(expression(paste(R[adj]^2," = 0.23")), "p = 0.021"), font=2, cex=3.5)
dev.off()

# Mother effect #################################################
linearMod_mother <- lm(data[,2] ~ data[,4], data=data)
summary(linearMod_mother)
a <- data[,4]
m <- data[,2]
linearMod_mother <- lm(m ~ a)
newx = seq(3,17,by = 0.5)
conf_interval <- predict(linearMod_mother, newdata=data.frame(a=newx), interval="confidence",level = 0.95)

png("mother_age_pred.png", width = 1300, height = 850)
par(mar=c(9,23,4,2), mgp=c(3, 3, 0))
plot(data[,4], data[,2], pch=19, xlab="", ylab="", xlim=c(3,16), cex=3, cex.lab=2.5, cex.axis=2.5, col="red2", xaxt="n", yaxt="n")
pinktrans <- rgb(255, 190, 190, 255, maxColorValue=255)
polygon(c(newx, rev(newx)), c(conf_interval[,2], rev(conf_interval[,3])),
     col = pinktrans, border = NA)
points(data[,4], data[,2], pch=19, cex=3, cex.lab=2.5, cex.axis=2.5, col="red2")
abline(6.200e-09, 1.818e-10, lwd=3, lty=2, col="red3")
axis(1, cex.axis=4)
axis(2, at=c(4.0e-09, 5.0e-09, 6.0e-09, 7.0e-09, 8.0e-09, 9.0e-09, 1.0e-08, 1.1e-08),label=c(expression("0.4 x 10"^-8), expression("0.5 x 10"^-8), expression("0.6 x 10"^-8), expression("0.7 x 10"^-8), expression("0.8 x 10"^-8), expression("0.9 x 10"^-8), expression("1.0 x 10"^-8), expression("1.1 x 10"^-8)),cex.axis=4, las=2)
mtext("Maternal age", 1, line=7, cex=4.5)
mtext("Mutation rate (per generation)", 2, line=20, cex=4.5)
text(c(4.1,4.6), c(1.12e-08, 1.06e-08), labels = c(expression(paste(R[adj]^2," = 0.09")), "p = 0.111"), font=2, cex=3.5)
dev.off()

## Age parents and phasing ##########################################
poo <- read.csv("assigned_each.tab", sep ="\t") # obtained from the phasing script
poo_p_p <- poo$prop_paternal[-20]
poo_p_m <- poo$prop_maternal[-20]
poo_p <- poo$paternal[-20]
poo_m <- poo$maternal[-20]
poo_n_p <- poo$paternal[-20]/poo$tot_pat[-20]
poo_n_m <- poo$maternal[-20]/poo$tot_mat[-20]
poo_np_p <- (poo_n_p)/(poo_n_p+poo_n_m)
poo_np_m <- (poo_n_m)/(poo_n_p+poo_n_m)
poo_i_p <- round((poo$unassigned+poo$assigned)[-20]*poo_np_p)
poo_i_m <- round((poo$unassigned+poo$assigned)[-20]*poo_np_m)
##
data_p <- cbind(data, poo_p_p, poo_p_m)
colnames(data_p)<-c("name", "mut", "p_age", "m_age", "p", "m", "poo_p_p", "poo_p_m")
lim_inf=min(data_p$p_age, data_p$m_age)
lim_sup=max(data_p$p_age, data_p$m_age)
##

## MODEL on upscaled LINEAR
data_i <- cbind(data, poo_i_p, poo_i_m)
colnames(data_i)<-c("name", "mut", "p_age", "m_age", "p", "m", "poo_i_p", "poo_i_m")
lim_inf=min(data_p$p_age, data_p$m_age)
lim_sup=max(data_p$p_age, data_p$m_age)

reg_age_f <- lm(data_i$poo_i_p ~ data_i$p_age)
summary(reg_age_f)
reg_age_m <- lm(data_i$poo_i_m ~ data_i$m_age)
summary(reg_age_m)
cor.test(data_i$poo_i_p, data_i$p_age, method="pearson")
cor.test(data_i$poo_i_m, data_i$m_age, method="pearson")
confint(reg_age_f)
confint(reg_age_m)

## confidence interval
a1=data_i$p_age
m=data_i$poo_i_p
fit<- lm(m ~ a1)
new1 = seq(4,17,by = 1)
conf_interval <- predict(fit, newdata=data.frame(a1=new1), interval="confidence",level = 0.95)
a_f=new1
conf_f=conf_interval
#
a1=data_i$m_age
m=data_i$poo_i_m
fit<- lm(m ~ a1)
new1 = seq(3,17,by = 1)
conf_interval <- predict(fit, newdata=data.frame(a1=new1), interval="confidence",level = 0.95)
a_m=new1
conf_m=conf_interval

# Plot model
png("infer_given.png", width = 1300, height = 850)
par(mar=c(9,12,4,2), mgp=c(3, 3, 0))
plot(data_i$p_age, data_i$poo_i_p, col="blue", pch=19, ylim=c(0,40), xlim=c(0, lim_sup), xlab="", ylab="",cex=3, cex.lab=2.5, cex.axis=2.5, xaxt="n", yaxt="n")
bluetrans <- rgb(204, 229, 255, 255, maxColorValue=255)
polygon(c(a_f, rev(a_f)), c(conf_f[,2], rev(conf_f[,3])), col = bluetrans, border = NA)
pinktrans <- rgb(255, 190, 190, 255, maxColorValue=255)
polygon(c(a_m, rev(a_m)), c(conf_m[,2], rev(conf_m[,3])), col = pinktrans, border = NA)
points(data_i$p_age, data_i$poo_i_p, col="blue", pch=19,cex=3)
points(data_i$m_age, data_i$poo_i_m, col="red2", pch=19,cex=3)
segments(4, 4.8399 + (1.8364*4), 20, 4.8399 + (1.8364*20), lwd=3, lty=2, col="blue")
text(c(14.5,15), c(21.5, 18.5), labels = c(expression(paste(R[adj]^2," = 0.41")), "p = 0.002"), font=2, cex=3, col="blue")
segments(3, 4.6497+ (0.3042*3), 20, 4.6497+ (0.3042*20), lwd=3, lty=2, col="red2")
text(c(14.5,15), c(4.5, 1.5), labels = c(expression(paste(R[adj]^2," = -0.01")), "p = 0.38"), font=2, cex=3, col="red2")
arrows(3,20,3,4.6497+ (0.3042*3), lwd=2, lty=1, col="red2")
arrows(4,20,4,4.8399 + (1.8364*4), lwd=2, lty=1, col="blue")
text(3.5, 22, "Puberty", cex=3.5, font=2)
legend("topleft", legend=c("Maternal", "Paternal"), pch=c(19,19), col=c("red2", "blue"), text.font=2, cex=3.5, bty = "n")
axis(1, cex.axis=4)
axis(2, cex.axis=4, las=2)
mtext("Parental age", 1, line=7, cex=4)
mtext("Upscaled phased mutations", 2, line=8, cex=4)
dev.off()

## Test of the model
# Predict mu with this model
nb_list=vector()
for(i in seq(1,nrow(data))){
    nb = (4.8399 + 1.8364*data[i,3]) + (4.6497+ 0.3042*data[i,4])
    nb_list=c(nb_list, nb)
}
call <- read.csv("../../de_novo_mutation/callability.txt", sep =" ", header=FALSE)
callability=mean(call[,2])
fnr=0.04020232294960846
mu_infer=(nb_list*(1-0.10887096774193548))/(2*callability*(1-fnr))

cor.test(mu_infer, data[,2], method="pearson")
fit <- lm(data[,2] ~ mu_infer)
summary(fit) # show results

png("model_upscaled_mu.png", width = 1300, height = 850)
par(mar=c(10,15,4,2), mgp=c(3, 3, 0))
plot(mu_infer, data[,2], pch=19, xlab="", ylab="", xlim=c(4.0e-9,1.2e-8), ylim=c(4.0e-9,1.2e-8),cex=3, cex.lab=2.5, cex.axis=2.5, xaxt="n", yaxt="n")
axis(1, at=c(4.0e-09, 5.0e-09, 6.0e-09, 7.0e-09, 8.0e-09, 9.0e-09, 1.0e-08, 1.1e-08, 1.2e-08),label=c("0.4", "0.5", "0.6", "0.7", "0.8","0.9","1.0","1.1","1.2"), cex.axis=4)
axis(2, at=c(4.0e-09, 5.0e-09, 6.0e-09, 7.0e-09, 8.0e-09, 9.0e-09, 1.0e-08, 1.1e-08, 1.2e-08),label=c("0.4", "0.5", "0.6", "0.7", "0.8","0.9","1.0","1.1","1.2"),cex.axis=4, las=2)
mtext(expression("Expected mutation rate x 10"^-8), 1, line=8, cex=3.5)
mtext(expression("Observed mutation rate x 10"^-8), 2, line=9, cex=3.5)
abline(-1.064e-09, 1.277, lty=2, lwd=3, col="grey40")
text(c(1.15e-08,1.155e-08), c(1.0e-08, 1.05e-08), labels = c("r = 0.54", "p = 0.016"), font=2, cex=3.5)
text(0.77e-8, 1.165e-8, expression(paste(mu, " =")), font=2, cex=2)
segments(0.8e-8, 1.165e-8, 1.2e-8, 1.165e-8, lwd=2, lty=1)
text(1.0e-8, 1.19e-8, expression(paste("(4.65 + 0.30 × a"[mat], " + 4.84 + 1.84 × a"[pat],") x (1-0.089)")), font=2, cex=2)
text(1.0e-8, 1.14e-8, expression(paste("2 x 2351302179 x (1-0.0402)")), font=2, cex=2)
dev.off()

### Same with Poisson #################################
## MODEL on upscaled POISSON
data_i <- cbind(data, poo_i_p, poo_i_m)
colnames(data_i)<-c("name", "mut", "p_age", "m_age", "p", "m", "poo_i_p", "poo_i_m")
lim_inf=min(data_p$p_age, data_p$m_age)
lim_sup=max(data_p$p_age, data_p$m_age)

# Regression
reg_age_f <- glm(data_i$poo_i_p ~ data_i$p_age, family = poisson)
summary(reg_age_f)
##reg_age_f <- glm(data_i$poo_i_p ~ data_i$p_age*data_i$p, family = poisson)
reg_age_m <- glm(data_i$poo_i_m ~ data_i$m_age, family = poisson)
summary(reg_age_m)
##
a1=data_i$p_age
m=data_i$poo_i_p
fit<- glm(m ~ a1, family = poisson)
new1 = seq(4,17,by = 0.5)
conf_interval <- predict(fit, newdata=data.frame(a1=new1), interval="confidence", type="response", level = 0.95, se.fit = TRUE)
a_f=new1
conf_f=conf_interval$fit
uci_f=conf_interval$fit+1.96*conf_interval$se.fit
lci_f=conf_interval$fit-1.96*conf_interval$se.fit
#
# Female
a1=data_i$m_age
m=data_i$poo_i_m
fit<- glm(m ~ a1, family = poisson)
new1 = seq(3,17,by = 0.5)
conf_interval <- predict(fit, newdata=data.frame(a1=new1), interval="confidence", type="response", level = 0.95, se.fit = TRUE)
a_m=new1
conf_m=conf_interval$fit
uci_m=conf_interval$fit+1.96*conf_interval$se.fit
lci_m=conf_interval$fit-1.96*conf_interval$se.fit
#

##plot
png("infer_given_poisson.png", width = 1300, height = 850)
par(mar=c(9,12,4,2), mgp=c(3, 3, 0))
plot(data_i$p_age, data_i$poo_i_p, col="blue", pch=19, ylim=c(0,40), xlim=c(0, lim_sup), xlab="", ylab="",cex=3, cex.lab=2.5, cex.axis=2.5, xaxt="n", yaxt="n")
bluetrans <- rgb(204, 229, 255, 255, maxColorValue=255)
polygon(c(a_f, rev(a_f)), c(lci_f, rev(uci_f)),col = bluetrans, border = NA)
pinktrans <- rgb(255, 190, 190, 255, maxColorValue=255)
polygon(c(a_m, rev(a_m)), c(lci_m, rev(uci_m)),col = pinktrans, border = NA)
lines(a_f, conf_f, lwd=3, lty=2, col="blue")
lines(a_m, conf_m, lwd=3, lty=2, col="red2")
points(data_i$p_age, data_i$poo_i_p, col="blue", pch=19, cex=3)
points(data_i$m_age, data_i$poo_i_m, col="red2", pch=19, cex=3)
##text(c(9,6.2), c(39, 36), labels = c("nb = exp(2.14+0.089xage)", "p < 0.001"), font=2, cex=3, col="blue")
##text(c(13,10.8), c(6, 3), labels = c("nb = exp(1.35+0.067xage)", "p < 0.01"), font=2, cex=3, col="red2")
legend("topleft", legend=c("Maternal", "Paternal"), pch=c(19,19), col=c("red2", "blue"), text.font=2, cex=3.5, bty = "n")
axis(1, cex.axis=4)
axis(2, cex.axis=4, las=2)
mtext("Parental age", 1, line=7, cex=4)
mtext("Upscaled phased mutations", 2, line=8, cex=4)
dev.off()

### Box plot contribution ##################################################################
png("norm_prop_box.png", width = 1300, height = 850)
##png("norm_prop_box.png", width = 950, height = 850)
par(mar=c(9,17,4,2), mgp=c(3, 3, 0))
boxplot(poo_np_m, poo_np_p, ylim=c(0,1), names=c("",""), ylab="", cex=3, cex.lab=2.5, cex.axis=2.5, col=c("red2","blue"), yaxt="n")
axis(2, cex.axis=3.5, las=2)
mtext("Proportion of phased", 2, line=12, cex=4)
mtext(expression(italic(de~novo)~mutations), 2, line=9, cex=4)
axis(1, at=c(1,2), label=c("Maternal", "Paternal"), cex.axis=4)
dev.off()
#

# Stats
se=sd(poo_np_p)/sqrt(length(poo_np_p))
se
mean(poo_np_p)-(2.1*se)
mean(poo_np_p)+(2.1*se)

# t test ####################################################
t.test(poo_np_p,poo_np_m)


#hierarchically aggregate multivariate composition data c/p/s using dirchlet.
#start 3 groups, 4 sites, plots w/in site, cores w/in plots.
#works ignoring plots within sites.
#Next add plots in between core and site level.
rm(list=ls())
library(runjags)

#1. generate pseudo data.----
#3 species relative abundances across 4 sites.
spp1 <- c(0.2,0.8,0.5,0.1)
spp2 <- c(0.3,0.1,0.4,0.1)
spp3 <- 1 - (spp1 + spp2)
y <- data.frame(spp1,spp2,spp3)
y <- as.matrix(y)
site_sd <- 0.02

#get some numbevr of pltos and cores within plots.
n.site <- nrow(y)
n.plot <- 15
n.core <- 10

#simulate from dirichlet distribution.
site.list <- list()
for(i in 1:n.site){
  plot.list <- list()
  for(j in 1:n.plot){
      cores <- DirichletReg::rdirichlet(n.core,y[i,])
      cores <- data.frame(cbind(rep(LETTERS[i],n.core),rep(LETTERS[j],n.core),LETTERS[1:n.core],cores))
      colnames(cores) <- c('siteID','plotID','coreID','spp1','spp2','spp3')
      plot.list[[j]] <- cores
  }
  site.list[[i]] <- do.call(rbind,plot.list)
}
dat <- do.call(rbind,site.list)
dat[,4:6] <- sapply(dat[4:6],as.character)
dat[,4:6] <- sapply(dat[4:6],as.numeric)
y <- dat[,4:6]

#core_plot, plot_site factors.
dat$plotID <- paste0(dat$siteID,'_',dat$plotID)
core_plot = dat$plotID
plot_site = dat[seq(1, nrow(dat), 3), ]$siteID

#2. specify JAGS model.----
jags.model = "
model {
#get plot level means.
for(i in 1:N.core){
  for(j in 1:N.spp){
    log(core.hat[i,j]) <- alpha + plot_mu[core_plot[i],j]
  }
  y[i,1:N.spp] ~ ddirch(core.hat[i,1:N.spp])
}

#get site level means.
for(i in 1:N.plot){
  for(j in 1:N.spp){
    #log(plot.hat[i,j]) <- alpha + site_mu[plot_site[i],j]
    log(plot.hat[i,j]) <- site_mu[plot_site[i],j]
  }
  plot_mu[i,1:N.spp] ~ ddirch(plot.hat[i,1:N.spp])
}

#prior
#for(i in 1:N.site){for(j in 1:N.spp){site_mu[i,j] ~ dnorm(0,1E-3)}}
alpha ~ dnorm(0, 1.0E-3)
for(i in 1:N.site){
  site_mu[i,1] <- 0
  for(j in 2:N.spp){
    site_mu[i,j] ~ dnorm(0,1E-3)
    }
}

#map to something useful.
#for(i in 1:N.site){
#  final_mu[i,1] <- alpha
#    for(j in 2:N.spp){
#      final_mu[i,j] <- site_mu[i,j] + alpha
#    }
#  }
}"

#3. Setup JAGS data object.----
jd <- list(y=as.matrix(y), N.site = n.site, N.core = nrow(y), N.plot = length(unique(dat$plotID)), N.spp = ncol(y),
           core_plot = as.factor(core_plot),
           plot_site = as.factor(plot_site))

#4. Run JAGS model.----
test <- run.jags(model = jags.model,
                 data = jd,
                 n.chains = 3,
                 monitor = c('site_mu'),
                 adapt = 200,
                 burnin = 2000,
                 sample = 1000)
out <- summary(test)
spp.sum <- matrix(out[,4], nrow = n.site, ncol = ncol(y))
spp.sum <- boot::inv.logit(spp.sum) / rowSums(boot::inv.logit(spp.sum))
spp.sum

testing_development/hierarchical means ddirch JAGS.r


powers = function(m)
   {n = -1
    function()
       {n <<- n + 1
        n^m}}

noncubic.squares = local(
   {squares = powers(2)
    cubes = powers(3)
    cube = cubes()
    function()
       {square = squares()
        while (1)
           {if (square > cube)
               {cube <<- cubes()
                next}
            else if (square < cube)
               {return(square)}
            else
               {square = squares()}}}})

for (i in 1:20)
    noncubic.squares()
for (i in 1:10)
    message(noncubic.squares())


model_soilheatflux <- function (netRadiationEquivalentEvaporation = 638.142,
         tau = 0.9983,
         soilEvaporation = 448.24){
    #'- Name: SoilHeatFlux -Version: 1.0, -Time step: 1
    #'- Description:
    #'            * Title: SoilHeatFlux Model
    #'            * Author: Pierre Martre
    #'            * Reference: Modelling energy balance in the wheat crop model SiriusQuality2:
    #'            Evapotranspiration and canopy and soil temperature calculations
    #'            * Institution: INRA/LEPSE Montpellier
    #'            * Abstract: The available energy in the soil
    #'- inputs:
    #'            * name: netRadiationEquivalentEvaporation
    #'                          ** variablecategory : state
    #'                          ** description : net Radiation Equivalent Evaporation
    #'                          ** datatype : DOUBLE
    #'                          ** default : 638.142
    #'                          ** min : 0
    #'                          ** max : 5000
    #'                          ** unit : g m-2 d-1
    #'                          ** uri : http://www1.clermont.inra.fr/siriusquality/?page_id=547
    #'                          ** inputtype : variable
    #'            * name: tau
    #'                          ** description : plant cover factor
    #'                          ** parametercategory : species
    #'                          ** datatype : DOUBLE
    #'                          ** default : 0.9983
    #'                          ** min : 0
    #'                          ** max : 100
    #'                          ** unit :
    #'                          ** uri : http://www1.clermont.inra.fr/siriusquality/?page_id=547
    #'                          ** inputtype : parameter
    #'            * name: soilEvaporation
    #'                          ** description : soil Evaporation
    #'                          ** variablecategory : state
    #'                          ** datatype : DOUBLE
    #'                          ** default : 448.240
    #'                          ** min : 0
    #'                          ** max : 10000
    #'                          ** unit : g m-2 d-1
    #'                          ** uri : http://www1.clermont.inra.fr/siriusquality/?page_id=547
    #'                          ** inputtype : variable
    #'- outputs:
    #'            * name: soilHeatFlux
    #'                          ** description : soil Heat Flux
    #'                          ** variablecategory : rate
    #'                          ** datatype : DOUBLE
    #'                          ** min : 0
    #'                          ** max : 10000
    #'                          ** unit : g m-2 d-1
    #'                          ** uri : http://www1.clermont.inra.fr/siriusquality/?page_id=547
    soilHeatFlux <- tau * netRadiationEquivalentEvaporation - soilEvaporation
    return (list('soilHeatFlux' = soilHeatFlux))
}


subroutine sknotl(x,n,knot,k)
implicit double precision(a-h,o-z)
double precision x(n),knot(n+6),a1,a2,a3,a4
integer     n,k,ndk,j

     # Allocate knots acording to the cutoffs given below

	# Cutoff constants

	 a1 = log(50d0)/log(2d0)  ; a2 = log(100d0)/log(2d0)
	 a3 = log(140d0)/log(2d0) ; a4 = log(200d0)/log(2d0)

	# Cutoff Criteria

        if(n<50)                    { ndk = n }
        else if (n>=50  & n<200)    { ndk = 2.**(a1+(a2-a1)*(n-50.)/150.)  }
        else if (n>=200 & n<800)    { ndk = 2.**(a2+(a3-a2)*(n-200.)/600.)  }
        else if (n>=800 & n<3200)   { ndk = 2.**(a3+(a4-a3)*(n-800.)/2400.)  }
        else if (n>=3200)           { ndk = 200. + float(n-3200)**.2 }

		 k = ndk + 6

     # Allocate Knots  ( note no account is taken of any weighting vector )

	do j=1,3   { knot(j) = x(1) }
	do j=1,ndk { knot(j+3) = x( 1 + (j-1)*(n-1)/(ndk-1) ) }
	do j=1,3   { knot(ndk+3+j) = x(n) }

return
end
subroutine splsm(x,y,w,n,match,nef,spar,dof,smo,s0,cov,ifcov,work)
#This subroutine performs a smoothing spline fit
# This was written by Trevor Hastie in 1990
# It has been modified from the S3 version by Trevor Hastie
# in July 2004, to accommodate the modified sbart routine in R
# and also to accommodate only the gam bakfit routine.
# Note that spar has changed, and we change it here to conform with
# the smooth.spline routine in R
#All arguments are either double precision or integer
#INPUT
#
#x	double length n ; x variable for smoothing
#y	double length n	; y variable for smoothing
#w	double length n ; weights for smoothing, > 0
#n	integer length above
#match 	integer length n -- in S language x[i] == sort(unique(x)[match[i]]
#		match is produced by subroutine namat
#nef	number of unique elements in x; so match has values between 1 and nef+1
#		missing data are given the match number nef+1
#spar	double smoothing parameter -1.5 <spar<1.5; default is 1
#dof	double  equivalent degrees of freedom
#		if dof is 0, spar is used
#               if 0< dof <1, dof = 1
#		if dof >=1, dof is used
#		note: dof does not use the constant term
#ifcov	integer if 1, the unscaled variance information is computed
#work	double workspace of length (10+2*4)*(nef+2)+5*nef+n+15
#
#OUTPUT
#
#x,y,w,n,match,nef  are untouched
#spar	if dof > 1, then spar is that which achieves dof
#dof	the dof of the fitted smooth. Note: even if dof was given
#		as 4, it will be returned as say 3.995 which is what
#		spar produces
#smo	double length n the fitted values, with weighted average 0
#s0	double weighted mean of y
#cov	double length nef the unscaled variance elements for the NONLINEAR
#		and UNIQUE part of smo, in the order of sort(unique(x))
#		cov is lev(i)/w(i) -h(i)/w where h(i) is the hat element from
#		the simple weighted least squares fit. This is passed on
#		to bakfit and used in gamcov
#
# splsm calls (eventually after some memory management dummy calls)
# sbart, the spline routine of Finbarr O'Sullivan, slightly modified
# by Trevor Hastie, 8/2/89

implicit double precision(a-h,o-z)
double precision x(*),y(*),w(*),spar,dof,smo(*),s0,cov(*),work(*)
integer n,match(*),nef
integer ifcov
# work should be (10+2*ld4)*nk+5*nef+n+15 double
# ld4 =4  nk<= nef+2
call splsm1(x,y,w,n,match,nef,spar,dof,smo,s0,cov,ifcov,
#	xin(nef+1),yin(nef+1), win(nef+1),   knot(n+6),
	work(1),   work(nef+2),work(2*nef+3),work(3*nef+4),
	work(3*nef+n+10))
return
end

subroutine splsm1(x,y,w,n,match,nef,spar,dof,smo,s0,lev,ifcov,
		xin,yin,win,knot,
		work)
implicit double precision(a-h,o-z)
double precision x(*),y(*),w(*),spar,dof,smo(*),s0,lev(*),work(*)
integer n,match(*),nef
integer ifcov
double precision xin(nef+1),yin(nef+1),win(nef+1),knot(nef+6)
integer nk,ldnk,ld4,k
double precision xmin,xrange
call suff(n,nef,match,x,y,w,xin,yin,win,work(1))
xmin=xin(1)
xrange=xin(nef)-xin(1)
do i=1,nef {xin(i)=(xin(i)-xmin)/xrange}
call sknotl(xin,nef,knot,k)
nk=k-4
ld4=4
ldnk=1 # p21p nd ldnk is not used
call splsm2(x,y,w,n,match,nef,spar,dof,smo,s0,lev,ifcov,
		xin,yin,win,knot,
#       coef(nk),sout(nef+1),  levout(nef+1), xwy(nk),
#	hs0(nk),           hs1(nk),           hs2(nk),
#       hs3(nk),
#	sg0(nk),           sg1(nk),           sg2(nk),
#       sg3(nk),
#	abd(ld4,nk),   p1ip(ld4,nk),
#       p2ip(ldnk,nk)
	work(1), work(nk+1),   work(nk+nef+2),work(nk+2*nef+3),
	work(2*nk+2*nef+3),work(3*nk+2*nef+3),work(4*nk+2*nef+3),
	work(5*nk+2*nef+3),
	work(6*nk+2*nef+3),work(7*nk+2*nef+3),work(8*nk+2*nef+3),
	work(9*nk+2*nef+3),
	work(10*nk+2*nef+3),work((10+ld4)*nk+2*nef+3),
	work((10+2*ld4)*nk+2*nef+3),
	ld4,ldnk,nk)

return
end
subroutine splsm2(x,y,w,n,match,nef,spar,dof,smo,s0,lev,ifcov,
		xin,yin,win,knot,
		coef,sout,levout,xwy,
		hs0,hs1,hs2,hs3,
		sg0,sg1,sg2,sg3,
		abd,p1ip,p2ip,ld4,ldnk,nk)
implicit double precision(a-h,o-z)
double precision x(*),y(*),w(*),spar,dof,smo(*),s0,lev(*)
integer n,match(*),nef
integer nk,ldnk,ld4
integer ifcov
double precision xin(nef+1),yin(nef+1),win(nef+1),knot(nk+4)
double precision coef(nk),sout(nef+1),levout(nef+1),xwy(nk),
	 	hs0(nk),hs1(nk),hs2(nk),hs3(nk),
         	sg0(nk),sg1(nk),sg2(nk),sg3(nk),
	 	abd(ld4,nk),p1ip(ld4,nk),p2ip(ldnk,*)
#    local variables
integer ispar,icrit,isetup,ier
double precision lspar,uspar,tol,penalt,
		sumwin,dofoff,crit,xbar,dsum,xsbar
double precision yssw, eps
integer maxit
# yssw is an additional parameter introduced in R version of sbart
double precision wmean
crit=0d0
# Note we only allow limited options here
if(dof <= 0d0){
# use spar
  ispar=1
  icrit=3
  dofoff=0d0
  }
else{
  if( dof < 1d0 )dof=1d0
  ispar=0
  icrit=3
  dofoff=dof+1d0
}
#Here we set some default parameters similar to the smooth.spline in R
isetup=0
ier=1
penalt=1d0
lspar= -1.5
uspar= 2.0
tol=1d-4
eps=2d-8
maxit=200
do i=1,nef
       sout(i)=yin(i)*yin(i)
sumwin=0d0
do i=1,nef
	sumwin=sumwin+win(i)
yssw=wmean(nef,sout,win)
s0=wmean(n,y,w)
# which should be equal to wmean(nef,yin,win)
yssw=yssw*(sumwin-s0*s0)

call sbart(penalt,dofoff,xin,yin,win,yssw,nef,knot,nk,
		  coef,sout,levout,crit,
                  icrit,spar,ispar,maxit,
                  lspar,uspar,tol,eps,
		  isetup,
		  xwy,
		  hs0,hs1,hs2,hs3,
		  sg0,sg1,sg2,sg3,
		  abd,p1ip,p2ip,ld4,ldnk,ier)
#return
#now clean up
do i=1,nef {
	win(i)=win(i)*win(i) #we sqrted them in sbart
	}
sbar=wmean(nef,sout,win)
xbar=wmean(nef,xin,win)

#now remove the linear leverage from the leverage for the smooths
# will be altered at this stage
do i=1,nef {lev(i)=(xin(i)-xbar)*sout(i)	}
xsbar=wmean(nef,lev,win)
do i=1,nef {lev(i)=(xin(i)-xbar)**2	}
dsum=wmean(nef,lev,win)
do i=1,nef {
	if(win(i)>0d0) {
		lev(i)=levout(i)/win(i)-1d0/sumwin -lev(i)/(sumwin*dsum)
		}
	else {lev(i)=0d0}
	}
dof=0d0
do i=1,nef {dof=dof+lev(i)*win(i)}
dof=dof+1d0
do i=1,nef
	sout(i)=sout(i)-sbar -(xin(i)-xbar)*xsbar/dsum
call unpck(n,nef,match,sout,smo)
return
end

double precision function wmean(n,y,w)
integer n
double precision y(n),w(n),wtot,wsum
wtot=0d0
wsum=0d0
do i=1,n{
	wsum=wsum+y(i)*w(i)
	wtot=wtot+w(i)
}
if(wtot > 0d0) {wmean=wsum/wtot} else {wmean=0d0}
return
end


# Generate and plot Brownian tree. Version #4.
# 7/27/16 aev
# gpBrownianTree4(m, n, clr, fn, ttl, dflg, seed, psz)
# Where: m - defines matrix m x m; n - limit of the number of moves;
#   fn - file name (.ext will be added); ttl - plot title; dflg - 0-no dump,
#   1-dump; seed - 0-center, 1-random: psz - picture size.
gpBrownianTree4 <- function(m, n, clr, fn, ttl, dflg=0, seed=0, psz=600)
{
  cat(" *** START:", date(), "m=",m, "n=",n, "clr=",clr, "psz=",psz, "\n");
  M <- matrix(c(0), ncol=m, nrow=m, byrow=TRUE);
  # Random seed
  if(seed==1)
    {x <- sample(1:m, 1, replace=FALSE);y <- sample(1:m, 1, replace=FALSE)}
  # Seed in center
  else {x <- m%/%2; y <- m%/%2}
  M[x,y]=1;
  pf=paste0(fn,".png");
  cat(" *** Plot file -",pf,"Seed:",x,"/",y,"\n");
  # Main loops
  for (i in 1:n) {
    if(i>1) {
      x <- sample(1:m, 1, replace=FALSE)
      y <- sample(1:m, 1, replace=FALSE)}
    while((x<=m && y<=m && x>0 && y>0)) {
      if(!(x+1<=m && y+1<=m && x-1>0 && y-1>0)) {break;}
      b=M[x+1,y+1]+M[x,y+1]+M[x-1,y+1]+M[x+1,y];
      b=b+M[x-1,y-1]+M[x-1,y]+M[x,y-1]+M[x+1,y-1];
      if(b!=0) {break;}
      x <- x + sample(-1:1, 1, replace=FALSE)
      y <- y + sample(-1:1, 1, replace=FALSE)
      if(!(x<=m && y<=m && x>0 && y>0))
        { x <- sample(1:m, 1, replace=FALSE)
          y <- sample(1:m, 1, replace=FALSE)
        }
    }
    M[x,y]=1;
  }
  plotmat(M, fn, clr, ttl, dflg, psz);
  cat(" *** END:",date(),"\n");
}
gpBrownianTree4(400,15000,"navy", "BT4R", "Brownian Tree v.4", 1);


####################################################################
## Double Seasonal Holt Winters method as per Taylor (2003)
## Periods must be nested.
## y can be an msts object, or periods can be passed explicitly.
####################################################################

#' Double-Seasonal Holt-Winters Forecasting
#'
#' Returns forecasts using Taylor's (2003) Double-Seasonal Holt-Winters method.
#'
#' Taylor's (2003) double-seasonal Holt-Winters method uses additive trend and
#' multiplicative seasonality, where there are two seasonal components which
#' are multiplied together. For example, with a series of half-hourly data, one
#' would set \code{period1=48} for the daily period and \code{period2=336} for
#' the weekly period. The smoothing parameter notation used here is different
#' from that in Taylor (2003); instead it matches that used in Hyndman et al
#' (2008) and that used for the \code{\link{ets}} function.
#'
#' @param y Either an \code{\link{msts}} object with two seasonal periods or a
#' numeric vector.
#' @param period1 Period of the shorter seasonal period. Only used if \code{y}
#' is not an \code{\link{msts}} object.
#' @param period2 Period of the longer seasonal period.  Only used if \code{y}
#' is not an \code{\link{msts}} object.
#' @param h Number of periods for forecasting.
#' @param alpha Smoothing parameter for the level. If \code{NULL}, the
#' parameter is estimated using least squares.
#' @param beta Smoothing parameter for the slope. If \code{NULL}, the parameter
#' is estimated using least squares.
#' @param gamma Smoothing parameter for the first seasonal period. If
#' \code{NULL}, the parameter is estimated using least squares.
#' @param omega Smoothing parameter for the second seasonal period. If
#' \code{NULL}, the parameter is estimated using least squares.
#' @param phi Autoregressive parameter. If \code{NULL}, the parameter is
#' estimated using least squares.
#' @param lambda Box-Cox transformation parameter. Ignored if \code{NULL}.
#' Otherwise, data transformed before model is estimated.
#' @param biasadj Use adjusted back-transformed mean for Box-Cox
#' transformations. If TRUE, point forecasts and fitted values are mean
#' forecast. Otherwise, these points can be considered the median of the
#' forecast densities. By default, the value is taken from what was used when
#' fitting the model.
#' @param armethod If TRUE, the forecasts are adjusted using an AR(1) model for
#' the errors.
#' @param model If it's specified, an existing model is applied to a new data
#' set.
#' @return An object of class "\code{forecast}" which is a list that includes the
#' following elements:
#'   \item{model}{A list containing information about the fitted model}
#'   \item{method}{The name of the forecasting method as a character string}
#'   \item{mean}{Point forecasts as a time series}
#'   \item{x}{The original time series.}
#'   \item{residuals}{Residuals from the fitted model. That is x minus fitted values.}
#'   \item{fitted}{Fitted values (one-step forecasts)}
#'
#' The function \code{summary} is used to obtain and print a summary of the
#' results, while the function \code{plot} produces a plot of the forecasts.
#'
#' The generic accessor functions \code{fitted.values} and \code{residuals}
#' extract useful features of the value returned by \code{dshw}.
#'
#' @author Rob J Hyndman
#' @seealso \code{\link[stats]{HoltWinters}}, \code{\link{ets}}.
#' @references Taylor, J.W. (2003) Short-term electricity demand forecasting
#' using double seasonal exponential smoothing. \emph{Journal of the
#' Operational Research Society}, \bold{54}, 799-805.
#'
#' Hyndman, R.J., Koehler, A.B., Ord, J.K., and Snyder, R.D. (2008)
#' \emph{Forecasting with exponential smoothing: the state space approach},
#' Springer-Verlag. \url{http://www.exponentialsmoothing.net}.
#' @keywords ts
#' @examples
#'
#' \dontrun{
#' fcast <- dshw(taylor)
#' plot(fcast)
#'
#' t <- seq(0,5,by=1/20)
#' x <- exp(sin(2*pi*t) + cos(2*pi*t*4) + rnorm(length(t),0,.1))
#' fit <- dshw(x,20,5)
#' plot(fit)
#' }
#'
#' @export
dshw <- function(y, period1=NULL, period2=NULL, h=2*max(period1,period2),
  alpha=NULL, beta=NULL, gamma=NULL, omega=NULL, phi=NULL, lambda=NULL, biasadj=FALSE,
  armethod=TRUE, model = NULL)
{
  if(min(y,na.rm=TRUE) <= 0)
    stop("dshw not suitable when data contain zeros or negative numbers")
  seriesname <- deparse(substitute(y))
  if (!is.null(model) && model$method == "DSHW") {
    period1 <- model$period1
    period2 <- model$period2
  } else if(any(class(y) == "msts") & (length(attr(y, "msts")) == 2)) {
	  period1 <- as.integer(sort(attr(y, "msts"))[1])
	  period2 <- as.integer(sort(attr(y, "msts"))[2])
  } else if(is.null(period1) | is.null(period2)) {
	  stop("Error in dshw(): y must either be an msts object with two seasonal periods OR the seasonal periods should be specified with period1= and period2=")
  } else {
    if(period1 > period2)
    {
      tmp <- period2
      period2 <- period1
      period1 <- tmp
    }
  }
  if(any(class(y) != "msts"))
    y <- msts(y, c(period1, period2))

  if(length(y) < 2*max(period2))
    stop("Insufficient data to estimate model")

  if(!armethod)
    phi <- 0

  if(period1 < 1 | period1 == period2)
    stop("Inappropriate periods")
  ratio <- period2/period1
  if(ratio-trunc(ratio) > 1e-10)
    stop("Seasonal periods are not nested")

  if (!is.null(model)) {
    lambda <- model$model$lambda
  }

  if (!is.null(lambda))
  {
    origy <- y
    y <- BoxCox(y, lambda)
  }

  if (!is.null(model)) {
    pars <- model$model
    alpha <- pars$alpha
    beta <- pars$beta
    gamma <- pars$gamma
    omega <- pars$omega
    phi <- pars$phi
  } else {
    pars <- rep(NA,5)
    if(!is.null(alpha))
      pars[1] <- alpha
    if(!is.null(beta))
      pars[2] <- beta
    if(!is.null(gamma))
      pars[3] <- gamma
    if(!is.null(omega))
      pars[4] <- omega
    if(!is.null(phi))
      pars[5] <- phi
  }

  # Estimate parameters
  if(sum(is.na(pars)) > 0)
  {
    pars <- par_dshw(y,period1,period2,pars)
    alpha <- pars[1]
    beta <- pars[2]
    gamma <- pars[3]
    omega <- pars[4]
    phi <- pars[5]
  }

  ## Allocate space
  n <- length(y)
  yhat <- numeric(n)

  ## Starting values
  I <- seasindex(y,period1)
  wstart <- seasindex(y,period2)
  wstart <- wstart / rep(I,ratio)
  w <- wstart
  x <- c(0,diff(y[1:period2]))
  t <- t.start <- mean(((y[1:period2]- y[(period2+1):(2*period2)])/period2 ) + x )/2
  s <- s.start <- (mean(y[1:(2*period2)])-(period2+0.5)*t)

  ## In-sample fit
  for(i in 1: n)
  {
    yhat[i] <- (s+t) * I[i]*w[i]
    snew <- alpha*(y[i]/(I[i]*w[i]))+(1-alpha)*(s+t)
    tnew <- beta*(snew-s)+(1-beta)*t
    I[i+period1] <- gamma*(y[i]/(snew*w[i])) + (1-gamma)*I[i]
    w[i+period2] <- omega*(y[i]/(snew*I[i])) + (1-omega)*w[i]
    s <- snew
    t <- tnew
  }

	# Forecasts
  fcast <- (s + (1:h)*t) * rep(I[n+(1:period1)],h/period1 + 1)[1:h] * rep(w[n+(1:period2)],h/period2 + 1)[1:h]
  fcast <- ts(fcast,frequency=frequency(y),start=tsp(y)[2]+1/tsp(y)[3])

  # Calculate MSE and MAPE
  yhat <- ts(yhat)
  tsp(yhat) <- tsp(y)
  yhat <- msts(yhat, c(period1, period2))
  e <- y - yhat
  e <- msts(e, c(period1, period2))
  if(armethod)
	{
		yhat <- yhat + phi * c(0,e[-n])
		e <- y - yhat
	  fcast <- fcast + phi^(1:h)*e[n]
	}
	mse <- mean(e^2)
	mape <- mean(abs(e)/y)*100

  end.y <- end(y)
  if(end.y[2] == frequency(y)) {
	  end.y[1] <- end.y[1]+1
	  end.y[2] <- 1
  } else {
	  end.y[2] <- end.y[2]+1
  }

  fcast <- msts(fcast, c(period1, period2))

  if(!is.null(lambda))
  {
    y <- origy
    fcast <- InvBoxCox(fcast, lambda, biasadj, var(e))
    attr(lambda, "biasadj") <- biasadj
    #Does this also need a biasadj backtransform?
    yhat <- InvBoxCox(yhat,lambda)
  }

  return(structure(list(mean=fcast,method="DSHW",x=y,residuals=e,fitted=yhat,series=seriesname,
              model=list(mape=mape,mse=mse,alpha=alpha,beta=beta, gamma=gamma,omega=omega,phi=phi,
                         lambda = lambda, l0=s.start,b0=t.start,s10=wstart,s20=I), period1 = period1,
                         period2 = period2),class="forecast"))

}

### Double Seasonal Holt-Winters smoothing parameter optimization

par_dshw <- function(y, period1, period2, pars)
{
  start <- c(0.1,0.01,0.001,0.001,0.0)[is.na(pars)]
  out <- optim(start, dshw.mse, y=y, period1=period1, period2=period2, pars=pars)
  pars[is.na(pars)] <- out$par
  return(pars)
}

dshw.mse <- function(par, y, period1, period2, pars)
{
  pars[is.na(pars)] <- par
  if(max(pars) > 0.99 | min(pars) < 0 | pars[5] > .9)
    return(1e20)
  else
    return(dshw(y, period1, period2, h=1, pars[1], pars[2], pars[3], pars[4], pars[5], armethod=(abs(pars[5]) >1e-7))$model$mse)
}

### Calculating seasonal indexes
seasindex <- function(y,p)
{
  #require(zoo)
  n <- length(y)
  n2 <- 2*p
  shorty <- y[1:n2]
  average <- numeric(n)
  simplema <- zoo::rollmean.default(shorty, p)
  if (identical(p%%2,0)) # Even order
  {
    centeredma <- zoo::rollmean.default(simplema[1:(n2-p+1)],2)
    average[p/2 + 1:p] <- shorty[p/2 + 1:p]/centeredma[1:p]
    si <- average[c(p+(1:(p/2)),(1+p/2):p)]
  }
  else # Odd order
  {
    average[(p-1)/2 + 1:p] <- shorty[(p-1)/2 + 1:p]/simplema[1:p]
    si <- average[c(p+(1:((p-1)/2)),(1+(p-1)/2):p)]
  }
  return(si)
}


# 4. faza: Analiza podatkov

#LINEARNA REGRESIJA

#Linearen model za skupno število stanovanj s slabo kakovostjo v odvisnosti od leta

podatki <- stanovanjske_razmere %>% group_by(leto)  %>%
  summarize(stanovanja_skupno = sum(stevilo_stanovanj))
podatki$leto <- as.numeric(podatki$leto)
fit <- lm(stanovanja_skupno ~ leto , data=podatki)

graf <- ggplot(podatki, aes(x = leto, y = stanovanja_skupno)) +
  geom_point() + geom_smooth(method=lm, se=FALSE) +
  labs(x = "Leto" , y = "SKupno število stanovanj" , title = "Ponazoritev premice linearne regresije - \n skupno število stanovanj v odvisnosti od leta")

predict(fit, data.frame(leto =c(2021, 2022)))


N = 20
n = 9
p1 = 5 / 20
p2 = 6 / 20
p3 = 9 / 20

X <- t(as.matrix(expand.grid(0:n, 0:n)))
X <- X[, colSums(X) <= n]
X <- rbind(X, n - colSums(X))
dimnames(X) <- list(letters[1:3])
mul <- X[1,] * X[2,]
mul <- mul * X[3,]
mul_nonzero_idx = which(mul!=0, arr.ind=T)
Y <- X[, mul_nonzero_idx]

result <- round(apply(Y, 2, function(x) dmultinom(x, prob=c(p1, p2, p3))), 4)

print(sum(result))


# Number Names

ones <- c("", "one", "two", "three", "four", "five", "six", "seven", "eight", "nine",
          "ten", "eleven", "twelve", "thirteen", "fourteen", "fifteen", "sixteen", "seventeen", "eighteen", "nineteen")
tens <- c("ten", "twenty", "thirty", "forty", "fifty", "sixty", "seventy", "eighty", "ninety")
mags <- c("", "thousand", "million", "billion", "trillion", "quadrillion", "quintillion")

return_hund <- function(input_number){
  if (input_number == 0) return("")
  num_text <- as.character()
  input_hund <- trunc(input_number / 100)
  input_ten <- trunc((input_number - input_hund * 100) / 10)
  input_one <- input_number %% 10
  if (input_number > 99) num_text <- paste0(ones[trunc(input_number / 100) + 1], "-hundred")
  if (input_ten < 2){
    if (input_ten == 0 & input_one == 0) return(num_text)
    if (input_hund > 0) return(paste0(num_text, " ", ones[input_ten * 10 + input_one + 1]))
    return(paste0(ones[input_ten * 10 + input_one + 1]))
  }
  ifelse(input_hund > 0,
         num_text <- paste0(num_text, " ", tens[input_ten]),
         num_text <- paste0(tens[input_ten])
  )
  if (input_one != 0) num_text <- paste0(num_text, "-", ones[input_one + 1])
  return(num_text)
}

make_number <- function(number){
  if (number == 0) return("zero")
  a <- abs(number)
  num_text <- as.character()
  g <- trunc(log(a, 10)) + 1
  for (i in c(seq(g, 1))){
    b <- floor(a / 1000 ^ (i - 1))
    x <- return_hund(b)
    if (x != "") num_text <- paste0(num_text, return_hund(b), " ", mags[i], " ")
    a <- a - b * 1000 ^ (i - 1)
  }
  return(ifelse(sign(number) > 0, num_text, paste("negative", num_text)))
}

my_num <- data.frame(nums = c(
  0, 1, -11, 13, 99, 100, -101, 113, -120, 450, -999, 1000, 1001, 1017, 3000, 3001,
  9999, 10000, 10001, 10100, 10101, 19000, 20001, 25467, 99999, 100000, 1056012,
  -200000, 200001, -200012, 2012567, -5685436, 5000201, -11627389, 100067652, 456000342)
)

my_num$text <- as.character(lapply(my_num$nums, make_number))
print(my_num, right=F)


#Dati

intervallo1 <- 1.74
intervallo2 <- 3.2
singoletto <- 13.33

denominatore <- 2.3216

domanda1 <- 1.92

domanda2_a <- 1.92
domanda2_b <- 2.06
domanda2_c <- 1.74
domanda2_d <- 3.2

domanda3_a <- 2.06
domanda3_b <- 2.1
domanda3_c <- 1.74
domanda3_d <- 1.92

#Svolgimento

EPSILON <- 0.001

f <- function(x) {
  ifelse(x < intervallo1, 0,
         ifelse(x >= intervallo1 && x < intervallo2, ((x - intervallo1)^2)/denominatore,
                ifelse(x >= intervallo2 && x < singoletto, 0.81,
                      ifelse(x >= singoletto, 1, NaN))))
}

f_calc <- function(x) {
  (x - intervallo1)^2/denominatore
}

par(bg = "black", fg = "White")
plot.new()
par(new = TRUE)
plot(Vectorize(f), xlab = "x", from = intervallo1-1, to = singoletto+1,
     type = "l", ylab = "F(x)", col = "Yellow2",
     col.axis = "white", col.lab = "white", lwd = 2)

for(i in seq(0, 1, 0.5)) {
  abline(h = i, lty="dotted", col = "Gray")
}

for(i in seq(0, singoletto+2, 0.5)) {
  abline(v = i, lty="dotted", col = "Gray")
}

domanda2 <- (f(domanda2_b)- f(domanda2_a))/(f(domanda2_d)-f(domanda2_c))

print(f(domanda1)-f(domanda1), digits=22)
print(domanda2, digits=22)
print(f(domanda3_b)-f(domanda3_a) + f(domanda3_d)- f(domanda3_c), digits=22)


library(R0)
library(uuid)
library(igraph)
library(ggnetwork)
library(data.table)
library(EpiDynamics)
library(scales)
library(tidyverse)

# https://www.ijidonline.com/article/S1201-9712(20)30119-3/pdf
weibull_mean = 6.4
# weibull_mean = 4.8
weibull_sd = 2.3
#
# > 10977 / (19e6 * .2)
# [1] 0.002888684

# get shape/scale for weibull distribution
fit_weibull = function(pars) {
  shape = pars[1]
  scale = pars[2]
  the_dist = rweibull(10000, shape, scale)
  the_sd = abs(sd(the_dist) - weibull_sd)
  the_mean =  abs(mean(the_dist) - weibull_mean)
  return(
    (the_sd * the_mean)^2
  )
}
weibull_params = optim(par = c(3, 7), fn = fit_weibull)
the_weibull_dist = rweibull(10000, weibull_params$par[1], weibull_params$par[2])
summary(the_weibull_dist)

fit_weibull_r0 = function(pars) {
  shape = pars[1]
  scale = pars[2]
  the_dist = rweibull(10000, shape, scale)
  mean_dist = mean(the_dist) - 2.5
  min_dist = min(the_dist) - 0.75

  return(
    (mean_dist)^2 + min_dist^2
  )
}
r0_params = optim(par = c(3, 7), fn = fit_weibull_r0)

run_case_simulation = function(initial_susceptible = 20e6, the_r0,
                               lockdown_date = NULL, lockdown_effect = NULL, r0_type = NULL) {
  this_r0 = the_r0
  current_susceptible = initial_susceptible

  case_info_list = list()

  generation = 0

  cases_gen_df = tibble(
    parent_id = NA,
    incubation_start = 0
  )
  n_cases_generated = 1

  continue_loop = T

  while (continue_loop) {
    loop_start = proc.time()

    # print(generation)

    if (n_cases_generated > current_susceptible) {
      # cat('too many cases generated!\n', n_cases_generated, '\n')
      n_cases_generated = current_susceptible
      suseptible_by_id = current_susceptible - 1:n_cases_generated
      # cat('n_cases_generated is now', n_cases_generated, '\n')
      cases_gen_df = head(cases_gen_df, n_cases_generated)
    } else {
      suseptible_by_id = current_susceptible - 1:n_cases_generated
    }
    # cat('n_cases_generated:', n_cases_generated, '\n')
    # cat('current_susceptible:', current_susceptible, '\n')
    #

    # suseptible_by_id = suseptible_by_id[suseptible_by_id > 0]

    if (current_susceptible < 0) {
      # cat('no more susceptible')
      break
    }

    the_id = initial_susceptible - suseptible_by_id
    # https://wwwnc.cdc.gov/eid/article/26/6/20-0357_article
    # https://www.ijidonline.com/article/S1201-9712(20)30119-3/pdf

    # incubation_time = rnorm(n_cases_generated, 3.96, 4.75)
    # incubation_time = rgamma(n_cases_generated, 4.37,  scale = 1.25)
    # incubation_time = rweibull(n_cases_generated, weibull_params$par[1], weibull_params$par[2])
    incubation_time = 5
    incubation_start_date = cases_gen_df$incubation_start
    incubation_end_date = incubation_start_date + incubation_time
    prob_running_into_someone_else = suseptible_by_id / initial_susceptible

    if (r0_type == 'weibull') {
      the_r0 = rweibull(n_cases_generated, r0_params$par[1], r0_params$par[2])
    } else if (r0_type == 'unif') {
      the_r0 = runif(n_cases_generated, this_r0*0.75, this_r0*1.25)
    }

    if (!is.null(lockdown_date)) {
      lockdown_effects = ifelse(incubation_start_date >= lockdown_date, lockdown_effect, 1)
      r0_adj = the_r0 * prob_running_into_someone_else * lockdown_effects
    } else {
      r0_adj = the_r0 * prob_running_into_someone_else
    }

    cases_generated = floor(r0_adj) + rbinom(length(r0_adj), 1, r0_adj - floor(r0_adj))
    n_cases_generated = sum(cases_generated)

    these_cases_df = data.table(
      the_id = the_id %>% as.integer(),
      generation = generation,
      parent_id = cases_gen_df$parent_id,
      incubation_time,
      incubation_start_date,
      incubation_end_date,
      prob_running_into_someone_else,
      r0_adj,
      cases_generated
    ) %>%
      setkey(the_id)

    case_info_list[[length(case_info_list) + 1]] = these_cases_df

    if (n_cases_generated > 0) {
      # important to sort by cases generated so the recyling works
      with_gen_cases = filter(these_cases_df, cases_generated > 0) %>% arrange(-cases_generated)

      cases_gen_df = data.table(
        parent_id = rep(with_gen_cases$the_id, length.out = n_cases_generated),
        incubation_start = runif(n_cases_generated, with_gen_cases$incubation_start_date, with_gen_cases$incubation_end_date)
      ) %>%
        setorder(incubation_start)

      stopifnot(nrow(cases_gen_df) == n_cases_generated)
    }

    # print(proc.time() - loop_start)
    generation = generation + 1
    current_susceptible = min(suseptible_by_id)
    continue_loop = n_cases_generated > 0 & current_susceptible > 0
  }

  case_info_df = rbindlist(case_info_list) %>%
    mutate(
      start_day = floor(incubation_start_date),
      end_day = floor(incubation_end_date)
    )
  return(rbindlist(case_info_list))
}

covid_ifr = 0.003
flu_ifr = 0.001
n_susceptible = 10e6

covid_case_simulation = run_case_simulation(r0_type = 'covid', the_r0 = 2.5,
                                            initial_susceptible = n_susceptible/2) %>%
  mutate(
    start_day = floor(incubation_start_date),
    died = rbinom(length(the_id), 1, covid_ifr),
    death_date = ifelse(died, start_day + 14, NA)
  )

generation_stats = group_by(covid_case_simulation, generation) %>%
  summarize(
    obs = n(),
    mean_cases = mean(cases_generated),
    mean_r0 = mean(r0_adj),
    mean_prob = mean(prob_running_into_someone_else ),
    min_prob = min(prob_running_into_someone_else),
    max_prob = max(prob_running_into_someone_else),
    start = min(incubation_start_date),
    end = max(incubation_end_date),
    mean_start = mean(incubation_start_date),
    mean_end = mean(incubation_end_date)
  )

ggplot(generation_stats, aes(start, max_prob, colour = factor(generation))) +
  geom_point() +
  geom_point(aes(y = min_prob))

covid_case_simulation$incubation_time
covid_case_simulation %>% pull(cases_generated) %>% summary()

ggplot(covid_case_simulation, aes(incubation_start_date, cases_generated, size = r0_adj)) +
  geom_point()

incubation_period = 5
initial_r0 = 2.5
gamma = 1/incubation_period
initial_beta = initial_r0 / incubation_period
initial_parameters <- c(beta = initial_beta, gamma = gamma)
initials <- c(S = 1 - 1e-06, I = 1e-06, R = 1 - (1 - 1e-06 - 1e-06))
# initials <- c(S = 1 - 1e-06, I = 1e-06, R = 1 - (1 - 1e-06 - 1e-06))
initial_covid_sir <- SIR(pars = initial_parameters, init = initials, time = 0:240)

counts_by_day = group_by(covid_case_simulation, start_day) %>%
  summarize(
    obs = n_distinct(the_id)
  )

sir_results =  initial_covid_sir$results %>%
  mutate(
    n_susceptible = n_susceptible/2 * S,
    n_cases = lag(n_susceptible, 1) - n_susceptible
  )
b = left_join(sir_results, counts_by_day, by = c('time' = 'start_day')) %>%
  mutate(
    obs= ifelse(is.na(obs), 0, obs),
    n_cases = ifelse(is.na(n_cases), 0, n_cases)
  )
with(b, cor(obs, n_cases))

ggplot(counts_by_day, aes(start_day, obs)) +
  geom_area(alpha = 0.3) +
  geom_area(data = sir_results, aes(time, n_cases), alpha = 0.3, fill = 'blue') +
  scale_y_continuous(labels = comma)

covid_case_simulation_lockdown = run_case_simulation(the_r0 = 2.5, r0_type = 'covid',
                                                     lockdown_date = 15, lockdown_effect = 0.65,
                                                     initial_susceptible = n_susceptible/2) %>%
  mutate(
    start_day = floor(incubation_start_date),
    died = rbinom(length(the_id), 1, covid_ifr),
    death_date = ifelse(died, start_day + 14, NA)
  )

flu_case_simulation = run_case_simulation(the_r0 = 1.3, r0_type = 'flu',
                                          initial_susceptible = 327e6/4) %>%
  mutate(
    start_day = floor(incubation_start_date),
    died = rbinom(length(the_id), 1, flu_ifr),
    death_date = ifelse(died, start_day + 14, NA)
  )

covid_cases_by_day = dplyr::group_by(covid_case_simulation, start_day) %>%
  dplyr::summarize(
    obs = n_distinct(the_id),
    died = sum(died)
  ) %>%
  mutate(
    cum_obs = cumsum(obs),
    Virus = 'COVID-19',
    with_lockdown = 'No'
  )

covid_cases_by_day_lockdown = dplyr::group_by(covid_case_simulation_lockdown, start_day) %>%
  dplyr::summarize(
    obs = n_distinct(the_id),
    died = sum(died)
  ) %>%
  mutate(
    cum_obs = cumsum(obs),
    Virus = 'COVID-19 Early Lockdown',
    with_lockdown = 'Yes'
  )

flu_cases_by_day = dplyr::group_by(flu_case_simulation, start_day) %>%
  dplyr::summarize(
    obs = n_distinct(the_id),
    died = sum(died)
  ) %>%
  mutate(
    cum_obs = cumsum(obs),
    Virus = 'Influenza',
    with_lockdown = 'No'
  )
sum(flu_cases_by_day$died)

stacked_stats = bind_rows(
  covid_cases_by_day, flu_cases_by_day,
  covid_cases_by_day_lockdown) %>%
  mutate(
    week = start_day %/% 7
  )

group_by(stacked_stats, Virus, with_lockdown) %>%
  summarize(
    t_obs = sum(obs),
    pct_infected = t_obs / n_susceptible,
    t_died = sum(died),
    crude_mortality_rate = t_died / n_susceptible,
    infection_fatality_rate = t_died / t_obs,
    time_period = as.numeric(max(start_day)-min(start_day))
  )
weekly_stats = group_by(stacked_stats, week, Virus, with_lockdown) %>%
  summarize(
    weekly_deaths = sum(died),
    weekly_cases = sum(obs)
  )
max(weekly_stats$weekly_deaths * 32.7)

ggplot(stacked_stats, aes(start_day, obs, fill = Virus)) +
  geom_area(alpha = 0.3, position = 'identity')

ggplot(weekly_stats, aes(week, weekly_deaths*32.7, colour = Virus)) +
  # facet_wrap(~Virus, scales = 'free_y') +
  geom_line() +
  geom_point()
  # geom_bar(stat = 'identity', position = 'identity')

# mGT_weibull <- generation.time("weibull", c(6.4, 2.3))
# mGT_weibull <- generation.time("gamma", c(5, 1.5))
# est.R0.EG(cases_by_day$obs, mGT_weibull, t = cases_by_day$start_day, begin = 0, end = 20)
#


#' Results from drawing different color balls from an urn
#'
#' @param n.iter The number of iterations in the monte carlo simulation (integer > 0)
#' @param n.colors The number of different colored balls (integer > 0)
#' @param n.balls The count of each color balls (vector of integers with same length as \code{n.colors})
#' @param n.drawn The number of balls drawn from the urn in each iteration
#' @param replacement Are the balls placed back in the urn after they're drawn? (defaults to \code{FALSE})
#' @param collapse Should the return be the draws or the count of each color? (defaults to \code{FALSE})
#' @param parallel Should the simulation take advantage of multiple cores (defaults to \code{TRUE} -
#'   highly recommended if \code{n.iter > 1e5})
#'
#' @return If \code{collapse == TRUE} the return is a \code{n.iter x n.colors} integer matrix
#'   where each row is the count of the colors of balls drawn. Otherwise, the return is a
#'   \code{n.iter x n.drawn} integer matrix where each row is the order that colors were drawn in.
#' @export
#'
draw.urn = function(n.iter = 1e5, n.colors = 2, n.balls = c(10,10),
                    n.drawn = 5, replacement = FALSE,
                    collapse = FALSE, parallel = TRUE) {
  stopifnot(n.iter %% 1 == 0 & n.iter > 0)
  stopifnot(n.colors %% 1 == 0 & n.colors > 0)
  stopifnot(all(n.balls %% 1 == 0) & all(n.balls > 0))
  stopifnot(length(n.balls) == n.colors)
  stopifnot(n.drawn %% 1 == 0 & n.drawn > 0)
  urn = unlist(lapply(seq_len(n.colors), FUN = function(i) rep(i, n.balls[i])))
  total.balls = sum(n.balls)
  if(!parallel) {
    results = lapply(seq_len(n.iter), FUN = function(i) {
      indices = sample(seq_len(total.balls), size = n.drawn, replace = replacement)
      urn[indices]
    })
  } else {
    results = mclapply(seq_len(n.iter), FUN = function(i) {
      indices = sample(seq_len(total.balls), size = n.drawn, replace = replacement)
      urn[indices]
    })
  }
  if(collapse) {
    return(t(sapply(results, FUN = function(x) {
      vapply(seq_len(n.colors), function(i) sum(x == i),1)
    })))
  }
  return(do.call(rbind, results))
}


library(MDPtoolbox)

MoveUp=matrix(c(0.3, 0.7, 0, 0,
            0, 0.9, 0.1, 0,
            0, 0.1, 0.9, 0,
            0, 0, 0.7, 0.3),
          nrow=4,ncol=4,byrow=TRUE)

MoveDown=matrix(c( 1, 0, 0, 0,
               0.7, 0.2, 0.1, 0,
               0, 0.1, 0.2, 0.7,
               0, 0, 0, 1),
            nrow=4,ncol=4,byrow=TRUE)

MoveLeft=matrix(c( 0.9, 0.1, 0, 0,
               0.1, 0.9, 0, 0,
               0, 0.7, 0.2, 0.1,
               0, 0, 0.1, 0.9),
            nrow=4,ncol=4,byrow=TRUE)

MoveRight=matrix(c( 0.9, 0.1, 0, 0,
                0.1, 0.2, 0.7, 0,
                0, 0, 0.9, 0.1,
                0, 0, 0.1, 0.9),
             nrow=4,ncol=4,byrow=TRUE)

AllActions=list(up=MoveUp, down=MoveDown, left=MoveLeft, right=MoveRight)

AllRewards=matrix(c( -2, -2, -2, -2,
                  -2, -2, -2, -2,
                  -2, -2, -2, -2,
                  20, 20, 20, 20),
               nrow=4,ncol=4,byrow=TRUE)

mdp_check(AllActions, AllRewards)

GridModel=mdp_policy_iteration(P=AllActions, R=AllRewards, discount = 0.1)

GridModel$policy
names(AllActions)[GridModel$policy]

GridModel$V

GridModel$iter

GridModel$time


#' @export
#' @title dist.plt
#' @description plots distributions in R, useful for setting up priors in Bayesian analyses
#' @param \code{dist}
#' @param \code{par1}
#' @param \code{par2}
#' @param \code{x}
#' @param \code{xl}
#' @param \code{col}
#' @return \code{add}
#' @return \code{alpha}
#' @return \code{plot.lines}
#' @family plotting
#' @author  unknown, \email{<unknown>@@dfo-mpo.gc.ca}
#' @export
dist.plt<-function(dist="beta",par1,par2,x,xl=c(0,1),col=1,add=F,alpha=0.05,plot.lines=F,title=''){

	z<-get(paste("r",dist,sep=''))(1000,par1,par2)
	if(missing(xl))xl<-range(z)
	if(missing(x))x<-seq(xl[1],xl[2],length=1000)
	y<-get(paste("d",dist,sep=''))(x,par1,par2)

	if(add==F){
#		plot.new()
		plot(x,y,type='l',col=col,xlab='',ylab='',main=title)
	}

	if(add==T)lines(x,y,col=col)
	out<-list(c(quantile(z, alpha/2),quantile(z, 0.5),quantile(z, 1-alpha/2)),mode=x[which(y==max(y))],mean=mean(z),var=var(z))
	if(plot.lines){
  	abline(v=out[[1]][2],lty=2)
	abline(v=out$mean,lty=3)
	abline(v=out$mode,lty=4)
	}

	out

}


fileName <- "rounds.txt"
rounds <- as.numeric(readChar(fileName, file.info(fileName)$size))

x = 1.0
pi = 1.0

for (i in 2:(rounds + 2)){
  x = x * -1
  pi = pi + (x / (2 * i - 1))
}

pi = pi * 4

printf <- function(...) cat(sprintf(...))
printf("%.16f\n", pi)