# demo: lsystem.r
# author: Daniel Adler

#
# geometry
#

deg2rad <- function( degree ) {
  return( degree*pi/180 )
}

rotZ.m3x3 <- function( degree ) {
  kc <- cos(deg2rad(degree))
  ks <- sin(deg2rad(degree))
  return(
    matrix(
      c(
        kc, -ks,   0,
        ks,  kc,   0,
         0,   0,   1
      ),ncol=3,byrow=TRUE
    )
  )
}

rotX.m3x3 <- function( degree ) {
  kc <- cos(deg2rad(degree))
  ks <- sin(deg2rad(degree))
  return(
    matrix(
      c(
         1,   0,   0,
         0,  kc, -ks,
         0,  ks,  kc
      ),ncol=3,byrow=TRUE
    )
  )
}

rotY.m3x3 <- function( degree ) {
  kc <- cos(deg2rad(degree))
  ks <- sin(deg2rad(degree))
  return(
    matrix(
      c(
        kc,   0,   ks,
         0,   1,    0,
       -ks,   0,   kc
      ),ncol=3,byrow=TRUE
    )
  )
}

rotZ <- function( v, degree ) {
  return( rotZ.m3x3(degree) %*% v)
}

rotX <- function( v, degree ) {
  return( rotX.m3x3(degree) %*% v)
}

rotY <- function( v, degree ) {
  return( rotY.m3x3(degree) %*% v)
}

#
# turtle graphics, rgl implementation:
#

turtle.init <- function(pos=c(0,0,0),head=0,pitch=90,roll=0,level=0) {
  rgl.clear("all")
  rgl.bg(color="black")
  rgl.light()
  return( list(pos=pos,head=head,pitch=pitch,roll=roll,level=level) )
}

turtle.move <- function(turtle, steps, color) {

  rm <- rotX.m3x3(turtle$pitch) %*% rotY.m3x3(turtle$head) %*% rotZ.m3x3(turtle$roll)

  from <- as.vector( turtle$pos )
  dir  <- rm %*% c(0,0,-1)
  to   <- from + dir * steps

  x <- c( from[1], to[1] )
  y <- c( from[2], to[2] )
  z <- c( from[3], to[3] )
  rgl.lines(x,y,z,col=color,size=1.5,alpha=0.5)
  turtle$pos <- to
  return(turtle)
}

turtle.pitch <- function(turtle, degree) {
  turtle$pitch <- turtle$pitch + degree
  return(turtle)
}

turtle.head <- function(turtle, degree) {
  turtle$head <- turtle$head + degree
  return(turtle)
}

turtle.roll <- function(turtle, degree) {
  turtle$roll <- turtle$roll + degree
  return(turtle)
}

#
# l-system general
#

lsystem.code <- function( x )
  substitute( x )

lsystem.gen <- function( x, grammar, levels=0 ) {
  code <- eval( substitute( substitute( REPLACE , grammar ), list(REPLACE=x) ) )
  if (levels)
    return( lsystem.gen( code , grammar , levels-1 ) )
  else
    return( code )
}

#
# l-system plot
#

lsystem.plot <- function( expr, level ) {
  turtle <- turtle.init(level=level)
  lsystem.eval( expr, turtle )
}

lsystem.eval <- function( expr, turtle ) {
  if ( length(expr) == 3 ) {
    turtle <- lsystem.eval( expr[[2]], turtle )
    turtle <- lsystem.eval( expr[[3]], turtle )
    turtle <- lsystem.eval( expr[[1]], turtle )
  } else if ( length(expr) == 2 ) {
    saved <- turtle
    turtle <- lsystem.eval( expr[[1]], turtle )
    turtle <- lsystem.eval( expr[[2]], turtle )
    turtle <- saved
  } else if ( length(expr) == 1 ) {
    if ( as.name(expr) == "stem" )      turtle <- turtle.move(turtle, 5, "brown")
    else if ( as.name(expr) == "short") turtle <- turtle.move(turtle, 5, "brown")
    else if ( as.name(expr) == "leaf" ) {
      rgl.spheres(turtle$pos[1],turtle$pos[2],turtle$pos[3],radius=0.1+turtle$level*0.3,color="green")
      rgl.sprites(turtle$pos[1],turtle$pos[2],turtle$pos[3],radius=0.5+turtle$level*0.3 ,color="green",texture=system.file("textures/particle.png",package="rgl"),textype="alpha",alpha=0.5)
    }
    else if ( as.name(expr) == "roll" ) turtle <- turtle.head(turtle, 60)
    else if ( as.name(expr) == "down" ) turtle <- turtle.pitch(turtle,10)
    else if ( as.name(expr) == "up" )   turtle <- turtle.pitch(turtle,-10)
    else if ( as.name(expr) == "left" ) turtle <- turtle.head(turtle, 1)
    else if ( as.name(expr) == "right") turtle <- turtle.head(turtle,-1.5)
    else if ( as.name(expr) == "turnleft") turtle <- turtle.head(turtle,20)
    else if ( as.name(expr) == "turnright") turtle <- turtle.head(turtle,-20)
    else if ( as.name(expr) == "turn") turtle <- turtle.roll(turtle,180)
  }
  return(turtle)
}

#
# example
#

simple <- function(level=0) {
  grammar <- list(
    stem=lsystem.code(
      stem-(up-stem-leaf)-stem-(down-stem-leaf)-stem-leaf
    )
  )
  plant <- lsystem.gen(lsystem.code(stem), grammar, level )
  lsystem.plot(plant,level)
}

rgl.demo.lsystem <- function(level=0) {
  gen   <- list(
    stem=lsystem.code(
      stem-left-stem-branch( turnleft-down-short-turnleft-down-stem-leaf)-right-right-stem--branch( turnright-up-short-turnright-up-short-turnright-short-stem-leaf)-left-left-left-stem-branch( turnleft-down-short-turnright-down-stem-leaf )-branch( up-turnright-short-up-turnleft-up-stem-leaf )
    )
  )
  plant <- lsystem.gen(lsystem.code(stem), gen, level )
  lsystem.plot(plant,level)
}

rgl.open()
rgl.demo.lsystem(level=1)


# train a random forest on original a9 data

library( randomForest )
library( caTools )

ntrees = 100

train_file = 'train.csv'
validation_file = 'test.csv'
label_index = 1

output_file = 'y_and_p.csv'

###

train <- read.csv( train_file, header = F )
validation <- read.csv( validation_file, header = F )

x_train = train[, -label_index]
y_train = train[, label_index]

x_validation = validation[, -label_index]
y_validation = validation[, label_index]

###

rf <- randomForest( x_train, as.factor( y_train ), ntree = ntrees, do.trace = 1 )  # mtry = nvars

p <- predict( rf, x_validation, type = 'prob' )
p_binary <- predict( rf, validation[,-1] )

probs =  p[,2]

accuracy = sum( p_binary == y_validation ) / length( p_binary )
cat( "accuracy:", accuracy, "\n" )

auc = colAUC( probs, ( y_validation + 1 ) / 2 )
auc = auc[1]

cat( "auc:", auc, "\n" )

write.table( cbind( y_validation, probs ), quote = F, col.names = F, row.names = F, sep = ',' )

###

# accuracy: 0.8485351
# auc: 0.8792633

# accuracy: 0.8491493
# auc: 0.8800499

# accuracy: 0.8468767
# auc: 0.8793631


# The main part of this script is derived from Nikaido-san

# argsments: ifile, oprefix, id, binsize

timestamp()

#############################################
library(data.table)

print(ifile)
print(oprefix)
print(id)
print(binsize)

#########################################
# Calculate whether RSS is significant
#########################################
# Load data: assuming[position (Int), depth (Float), RSS (Bool)]
dt = fread(sprintf("gzip -dc %s", ifile), header=TRUE)
# dt[, depth.sm := runmed(depth, k = 17)]
# df = as.data.frame(dt)

# Binning
breaks = seq(dt[, min(bp)], dt[, max(bp)] + binsize, by = binsize)
bpbin = .bincode(dt$bp, breaks, right=FALSE)
dt[, bpmed := breaks[bpbin] + floor(binsize/2)]

dt2 = copy(dt)
dt2 = dt2[, depthMean := mean(depth), by = bpmed]
dt2 = unique(dt2[, .(bpmed, depthMean)], by=NULL)
dim(dt2)
posRSS = dt[RSS == TRUE, max(bp)]
dt2[, RSS := (bpmed < posRSS)]

# Encode relative distance (the distance from the closest upstream RS site candidate)
if(strand == "+"){
        dt2[bpmed < posRSS, bpmed_relative := bpmed-min(bpmed)]
        dt2[bpmed >= posRSS, bpmed_relative := bpmed-min(bpmed)]
}else{
        dt2[bpmed < posRSS, bpmed_relative := max(bpmed)-bpmed]
        dt2[bpmed >= posRSS, bpmed_relative := max(bpmed)-bpmed]
}

setnames(dt2, "bpmed", "bp")
setnames(dt2, "bpmed_relative", "bp_relative")
setnames(dt2, "depthMean", "depth")
dt2[, depth.sm := runmed(depth, k = 17)]

df = as.data.frame(dt2)

# Perform linear regression
df.lm    = lm(depth ~ bp, data = df)
df.rss.lm = lm(depth ~ bp + RSS, data = df)

df.rel.lm = lm(depth ~ bp_relative, data = df)

df.sm.lm = lm(depth.sm ~ bp, data = df)
df.sm.rss.lm = lm(depth.sm ~ bp + RSS, data = df)

# Obtain fitted values from the estimated paramter values
y.pred    = fitted(df.lm)
y.rss.pred = fitted(df.rss.lm)

y.rel.pred = fitted(df.rel.lm)

y.sm.pred = fitted(df.sm.lm)
y.sm.rss.pred = fitted(df.sm.rss.lm)

# Peform significance test for the slope
lm.anv = anova(df.lm, df.rss.lm)
print(lm.anv)

aic.lm = AIC(df.lm)
aic.lm.rel = AIC(df.rel.lm)

# https://stats.stackexchange.com/questions/8513/test-equivalence-of-non-nested-models/8519#8519
## The Cox Test for Comparing Non-Nested Models
require(lmtest)
pval_cox_2_over_1 = coxtest(df.lm, df.rel.lm)[[4]][1]
pval_cox_1_over_2 = coxtest(df.lm, df.rel.lm)[[4]][2]
print(pval_cox_2_over_1)
print(pval_cox_1_over_2)

lm.sm.anv = anova(df.sm.lm, df.sm.rss.lm)
print(lm.sm.anv)

pval.raw = lm.anv[2,6]
pval.sm = lm.sm.anv[2,6]

##############################
# Plot
##############################

labels3 = c("raw", "baseline (raw)", "RSS (raw)", "rel_dist (raw)")
n3 = length(labels3)
title.txt3 = sprintf("%s\np_raw=%.3e p_cox=%.3e dAIC(baseline-rel_dist)=%.1f", id, pval.raw, pval_cox_2_over_1, aic.lm - aic.lm.rel)

labels2 = c("smooth", "predict (smooth)", "RSS (smooth)")
n2 = length(labels2)

labels = c("raw", "smooth", "predict (raw)", "predict (smooth)", "RSS (raw)", "RSS (smooth)")
title.txt = sprintf("%s\np_raw=%.3e p_smooth=%.3e", id, pval.raw, pval.sm)
n = length(labels)
ymax = max(c(df$depth.sm, df$depth)) * 2

###
pdfname = sprintf("%s.pdf", oprefix)
pdf(pdfname)

matplot(df$bp, cbind(df$depth.sm, y.sm.pred, y.sm.rss.pred),
        type =  c("s", rep("l",(n2-1))),
        lty = n2:1, col = 1:n2,
        main = title.txt,
        lwd = c(1, rep(2, n2-1)),
        ylim = c(0, ymax),
        ylab = "Depth of reads", xlab = "bp")
legend("topleft", legend = labels2, col = 1:n2, lty = n2:1, lwd = c(1, rep(2, n2-1)))
rug(posRSS, lwd = 1)

matplot(df$bp, cbind(df$depth, df$depth.sm, y.pred, y.sm.pred, y.rss.pred, y.sm.rss.pred),
        type =  c("s", "s", rep("l",(n-2))),
        lty = n2:1, col = 1:n,
        main = title.txt,
        lwd = c(1, 1, rep(2, n-2)),
        ylim = c(0, ymax),
        ylab = "Depth of reads", xlab = "bp")
legend("topleft", legend = labels, col = 1:n, lty = n:1, lwd = c(1, 1, rep(2, n-2)))
rug(posRSS, lwd = 1)

matplot(df$bp, cbind(df$depth, y.pred, y.rss.pred, y.rel.pred),
        type =  c("s", "s", rep("l",(n3-1))),
        lty = n3:1, col = 1:n3,
        main = title.txt3,
        lwd = c(1, rep(2, n3-1)),
        ylim = c(0, ymax),
        ylab = "Depth of reads", xlab = "bp")
legend("topleft", legend = labels3, col = 1:n3, lty = n3:1, lwd = c(1, rep(2, n3-1)))
rug(posRSS, lwd = 1)

dev.off()

###
pngname = sprintf("%s.smooth.png", oprefix)
png(pngname)

matplot(df$bp, cbind(df$depth.sm, y.sm.pred, y.sm.rss.pred),
        type =  c("s", rep("l",(n2-1))),
        lty = n2:1, col = 1:n2,
        main = title.txt,
        lwd = c(1, rep(2, n2-1)),
        ylim = c(0, ymax),
        ylab = "Depth of reads", xlab = "bp")
legend("topleft", legend = labels2, col = 1:n2, lty = n2:1, lwd = c(1, rep(2, n2-1)))
rug(posRSS, lwd = 1)

dev.off()

###
pngname = sprintf("%s.rawSmooth.png", oprefix)
png(pngname)

matplot(df$bp, cbind(df$depth, df$depth.sm, y.pred, y.sm.pred, y.rss.pred, y.sm.rss.pred),
        type =  c("s", "s", rep("l",(n-2))),
        lty = n2:1, col = 1:n,
        main = title.txt,
        lwd = c(1, 1, rep(2, n-2)),
        ylim = c(0, ymax),
        ylab = "Depth of reads", xlab = "bp")
legend("topleft", legend = labels, col = 1:n, lty = n:1, lwd = c(1, 1, rep(2, n-2)))
rug(posRSS, lwd = 1)

dev.off()

###
pngname = sprintf("%s.raw_rel_dist.png", oprefix)
png(pngname)

matplot(df$bp, cbind(df$depth, y.pred, y.rss.pred, y.rel.pred),
        type =  c("s", "s", rep("l",(n3-1))),
        lty = n3:1, col = 1:n3,
        main = title.txt3,
        lwd = c(1, rep(2, n3-1)),
        ylim = c(0, ymax),
        ylab = "Depth of reads", xlab = "bp")
legend("topleft", legend = labels3, col = 1:n3, lty = n3:1, lwd = c(1, rep(2, n3-1)))
rug(posRSS, lwd = 1)

dev.off()

#############################
# Save
#############################
dt2[, y.pred := y.pred]
dt2[, y.rss.pred := y.rss.pred]
dt2[, y.rel.pred := y.rel.pred]
dt2[, y.sm.pred := y.sm.pred]
dt2[, y.sm.rss.pred := y.sm.rss.pred]

ofile = sprintf("%s.res.txt.gz", oprefix)
gzHandler = gzfile(ofile, "w")
write.table(dt2, gzHandler, sep = "\t", quote=FALSE, row.names=FALSE)
close(gzHandler)

ofile = sprintf("%s.pval.txt", oprefix)
write.table(data.table(
						id = id,
						pval.raw = pval.raw,
                                                pval.raw.rel = pval_cox_2_over_1,
                                                pval.raw.rel_reverse = pval_cox_1_over_2,
                                                aic_lm = aic.lm,
                                                aic_lm_rel = aic.lm.rel,
						pval.sm = pval.sm,
						df.lm_Intercept = coef(df.lm)[1],
						df.lm_bp = coef(df.lm)[2],
						df.rss.lm_Intercept = coef(df.rss.lm)[1],
						df.rss.lm_bp = coef(df.rss.lm)[2],
						df.rss.lm_RSSTRUE = coef(df.rss.lm)[3],
                                                df.rel.lm_Intercept = coef(df.rel.lm)[1],
                                                df.rel.lm_bp = coef(df.rel.lm)[2],
						df.sm.lm_Intercept = coef(df.sm.lm)[1],
						df.sm.lm_bp = coef(df.sm.lm)[2],
						df.sm.rss.lm_Intercept = coef(df.sm.rss.lm)[1],
						df.sm.rss.lm_bp = coef(df.sm.rss.lm)[2],
						df.sm.rss.lm_RSSTRUE = coef(df.sm.rss.lm)[3]
					),
	ofile, sep = "\t", quote=FALSE, row.names=FALSE)

##########################################
sessionInfo()

timestamp()


[[[[[
   KRAFT INEQUALITY CRITERION FOR CONSTRUCTING COMPUTERS
   Take as input requirement pairs (output, size of program)
   and produce as output assignment pairs (program, output).

   We assume that the requirements are consistent.
   I.e. the sum of 1/2 raised to each size is <= unity.
   Then we can produce a set of assignments that meets
   the requirements and is prefex free, i.e. no extension
   of a valid program is a valid program.

   The basic data structure in this program is the free space pool.
   That's a list of prefixes all of whose extensions (by zero
   or more bits) are unassigned programs.  Initially this is the
   list consisting of the empty string because everything is free.

   The algorithm consists of assigning that program that meets
   each requirement that is available and that comes first in
   lexicographic order (0 before 1).

   The free space pool is kept in lexicographic order, to facilitate
   searching.  So the algorithm is to look for the first prefix in
   the pool that is <= the requested size in each requirement.

   If it has exactly the requested size, then that prefix is the
   program assigned to the output in the requirement.  If not,
   the prefix must be smaller than the requirement, and represents
   a piece of free storage that is a power of two larger than needed.
   So as program we assign the prefix extended by sufficiently many
   0's to reach the requested size, and then the prefix is replaced
   in the free space pool by prefix00001, prefix0001, prefix001,
   prefix01, prefix1, for all sizes up to the assigned size.
   This will always work if the Kraft inequality is satisfied.

   If this algorithm is given the requirements
      (0 1) (1 2)  (2 3)   (3 4)...
   (i.e., a 1-bit p for 0, a 2-bit p for 1, a 3-bit p for 2, etc.)
   it will produce the assignments
      (0 0) (10 1) (110 2) (1110 3)...
   (i.e., p = 0 yields 0, p = 10 yields 1, p = 110 yields 2, etc.)
   In this case the free storage pool will always consist of a
   single piece.

   Key fact: if you follow this first-fit algorithm, the free space
   will appear in blocks in the unit interval whose sizes are all
   distinct powers of two, and in order of increasing size.  So
   if an allocation cannot be made, the piece requested must be
   larger (at least twice as large) as the last & largest piece.
   But the total free storage is less than twice the size of the
   last & largest free piece, so allocating this would have violated
   the Kraft inequality.

   To actually run these programs, we have to feed the output of
   this program kraft.l into the previous one, exec.l.
   So there will in fact be an additional prefix in front of the
   assigned programs to tell U how to do kraft.l and how to do exec.l.

   Kraft is written as a function that is applied to a finite list
   of requirements and produces the corresponding finite list of
   assignments.  Exec.l will use try to run the requirement generator
   for more and more time to produce longer and longer lists of
   assignments.   It will then use the Kraft function to transform
   these into longer and longer lists of assignments, which it will
   use to actually run individual programs by reading them bit by
   bit as required. The Kraft function has the property that applying
   it to a longer list of requirements just produces a longer list
   of assignments.  I.e., it's monotone, it never changes its mind.
]]]]]

[used to assign a program to an output]

define (extend-with-0s bit-string [to] given-length)
   if = length bit-string given-length  [then]
      bit-string  [else]
   append (extend-with-0s bit-string [to] - given-length 1)
          cons 0 nil

define      extend-with-0s
value       (lambda (bit-string given-length) (if (= (length b
            it-string) given-length) bit-string (append (exten
            d-with-0s bit-string (- given-length 1)) (cons 0 n
            il))))

[test it]

(extend-with-0s '(1 1 1) [to] 6)

expression  (extend-with-0s (' (1 1 1)) 6)
value       (1 1 1 0 0 0)

(extend-with-0s '(1 1 1) [to] 5)

expression  (extend-with-0s (' (1 1 1)) 5)
value       (1 1 1 0 0)

(extend-with-0s '(1 1 1) [to] 4)

expression  (extend-with-0s (' (1 1 1)) 4)
value       (1 1 1 0)

(extend-with-0s '(1 1 1) [to] 3)

expression  (extend-with-0s (' (1 1 1)) 3)
value       (1 1 1)

[used to subtract storage from a piece of free storage]

define (remove-piece free-prefix size-of-program)
   if = size-of-program length free-prefix
       nil  [then no storage left, else]
   cons append (extend-with-0s free-prefix [to] - size-of-program 1)
               cons 1 nil
        (remove-piece free-prefix - size-of-program 1)

define      remove-piece
value       (lambda (free-prefix size-of-program) (if (= size-
            of-program (length free-prefix)) nil (cons (append
             (extend-with-0s free-prefix (- size-of-program 1)
            ) (cons 1 nil)) (remove-piece free-prefix (- size-
            of-program 1)))))

[test it]

(remove-piece '(1 1 1) 6)

expression  (remove-piece (' (1 1 1)) 6)
value       ((1 1 1 0 0 1) (1 1 1 0 1) (1 1 1 1))

(remove-piece '(1 1 1) 5)

expression  (remove-piece (' (1 1 1)) 5)
value       ((1 1 1 0 1) (1 1 1 1))

(remove-piece '(1 1 1) 4)

expression  (remove-piece (' (1 1 1)) 4)
value       ((1 1 1 1))

(remove-piece '(1 1 1) 3)

expression  (remove-piece (' (1 1 1)) 3)
value       ()

[
   Make-assignments uses debug to show us the
   free-space-pool after making each assignment.
   If an assignment cannot be made because
   there is not enough storage, we just skip it.
]
define (make-assignments free-space-pool requirements)

   let free-space-pool   debug free-space-pool
                         [Done just to show pool!]

   if  atom requirements nil  [no requirements => no assignments]
                              [If so, we're finished!]

   let requirement       car  requirements
   let requirements      cdr  requirements
   let output-of-program car  requirement
   let size-of-program   cadr requirement
   let already-scanned   nil
   let not-yet-scanned   free-space-pool

   let (loop-thru-free-space-pool) [DEFINE IT!]

       if atom not-yet-scanned [cannot make this assignment!]
          [indicate problem and go to next requirement]
          cons not-enough-storage!
               (make-assignments free-space-pool requirements)

       let free-prefix      car not-yet-scanned
       let not-yet-scanned  cdr not-yet-scanned
       if < size-of-program length free-prefix

          [doesn't fit --- continue scanning]
          let already-scanned
              append already-scanned
                     cons free-prefix nil
          (loop-thru-free-space-pool)

       [fits! --- make assignment]
       [add to list of rest of assignments]
       let free-space-pool
           append already-scanned
           append (remove-piece free-prefix size-of-program)
                  not-yet-scanned

       let assignment
           [make assignment - add to list of rest of assignments]
           [found free piece where it fits!]
           [extend with zeros to correct size]
           cons (extend-with-0s free-prefix [to] size-of-program)
           cons output-of-program
                nil

       [return full list of assignments]
       cons assignment
            (make-assignments free-space-pool requirements)

   [NOW DO IT!]
   (loop-thru-free-space-pool)

define      make-assignments
value       (lambda (free-space-pool requirements) ((' (lambda
             (free-space-pool) (if (atom requirements) nil (('
             (lambda (requirement) ((' (lambda (requirements)
            ((' (lambda (output-of-program) ((' (lambda (size-
            of-program) ((' (lambda (already-scanned) ((' (lam
            bda (not-yet-scanned) ((' (lambda (loop-thru-free-
            space-pool) (loop-thru-free-space-pool))) (' (lamb
            da () (if (atom not-yet-scanned) (cons not-enough-
            storage! (make-assignments free-space-pool require
            ments)) ((' (lambda (free-prefix) ((' (lambda (not
            -yet-scanned) (if (< size-of-program (length free-
            prefix)) ((' (lambda (already-scanned) (loop-thru-
            free-space-pool))) (append already-scanned (cons f
            ree-prefix nil))) ((' (lambda (free-space-pool) ((
            ' (lambda (assignment) (cons assignment (make-assi
            gnments free-space-pool requirements)))) (cons (ex
            tend-with-0s free-prefix size-of-program) (cons ou
            tput-of-program nil))))) (append already-scanned (
            append (remove-piece free-prefix size-of-program)
            not-yet-scanned)))))) (cdr not-yet-scanned)))) (ca
            r not-yet-scanned)))))))) free-space-pool))) nil))
            ) (car (cdr requirement))))) (car requirement))))
            (cdr requirements)))) (car requirements))))) (debu
            g free-space-pool)))

[put it all together]

define (kraft requirements)

   let free-space-pool '(()) [everything free]

   (make-assignments free-space-pool requirements)

define      kraft
value       (lambda (requirements) ((' (lambda (free-space-poo
            l) (make-assignments free-space-pool requirements)
            )) (' (()))))

[TEST KRAFT!]

(kraft '((x 0) (y 1)))

expression  (kraft (' ((x 0) (y 1))))
debug       (())
debug       ()
debug       ()
value       ((() x) not-enough-storage!)

(kraft '((a 1) (b 0) (c 1)))

expression  (kraft (' ((a 1) (b 0) (c 1))))
debug       (())
debug       ((1))
debug       ((1))
debug       ()
value       (((0) a) not-enough-storage! ((1) c))

(kraft '((x 1) (y 2)))

expression  (kraft (' ((x 1) (y 2))))
debug       (())
debug       ((1))
debug       ((1 1))
value       (((0) x) ((1 0) y))

(kraft '((a 1) (b 2) (c 3) (d 4) (e 5)))

expression  (kraft (' ((a 1) (b 2) (c 3) (d 4) (e 5))))
debug       (())
debug       ((1))
debug       ((1 1))
debug       ((1 1 1))
debug       ((1 1 1 1))
debug       ((1 1 1 1 1))
value       (((0) a) ((1 0) b) ((1 1 0) c) ((1 1 1 0) d) ((1 1
             1 1 0) e))

(kraft '((e 5) (d 4) (c 3) (b 2) (a 1)))

expression  (kraft (' ((e 5) (d 4) (c 3) (b 2) (a 1))))
debug       (())
debug       ((0 0 0 0 1) (0 0 0 1) (0 0 1) (0 1) (1))
debug       ((0 0 0 0 1) (0 0 1) (0 1) (1))
debug       ((0 0 0 0 1) (0 1) (1))
debug       ((0 0 0 0 1) (1))
debug       ((0 0 0 0 1))
value       (((0 0 0 0 0) e) ((0 0 0 1) d) ((0 0 1) c) ((0 1)
            b) ((1) a))

(kraft '((e 5) (c 3) (d 4) (a 1) (b 2)))

expression  (kraft (' ((e 5) (c 3) (d 4) (a 1) (b 2))))
debug       (())
debug       ((0 0 0 0 1) (0 0 0 1) (0 0 1) (0 1) (1))
debug       ((0 0 0 0 1) (0 0 0 1) (0 1) (1))
debug       ((0 0 0 0 1) (0 1) (1))
debug       ((0 0 0 0 1) (0 1))
debug       ((0 0 0 0 1))
value       (((0 0 0 0 0) e) ((0 0 1) c) ((0 0 0 1) d) ((1) a)
             ((0 1) b))


=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


suppressPackageStartupMessages(library(kazaam))

if (comm.rank() == 0){
  x = matrix(rnorm(30), 10)
  pca = prcomp(x)
  sdev = pca$sdev
  rotation = pca$rotation
  center = pca$center
  scale = pca$scale
} else {
  x = NULL
}

dx = expand(x)
pca_test = prcomp(dx)

x_test = collapse(pca_test$x)

comm.print(all.equal(sdev, pca_test$sdev, check.attributes=F))
comm.print(all.equal(abs(rotation), abs(pca_test$rotation), check.attributes=F))
comm.print(all.equal(center, pca_test$center, check.attributes=F))
comm.print(all.equal(scale, pca_test$scale, check.attributes=F))
comm.print(all.equal(abs(pca$x), abs(x_test), check.attributes=F))

finalize()


#' 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
}


spiral_matrix <- function(n) {
    stopifnot(is.numeric(n))
    stopifnot(n > 0)
    steps <- c(1, n, -1, -n)
    reps <- n - seq_len(n * 2 - 1L) %/% 2
    indicies <- rep(rep_len(steps, length(reps)), reps)
    indicies <- cumsum(indicies)
    values <- integer(length(indicies))
    values[indicies] <- seq_along(indicies)
    matrix(values, n, n, byrow = TRUE)
}


##### 医学統計勉強会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()


############ This file contains functions to compute various features over arbitrary windows time-series data.

suppressMessages(library(stringr))

zeroCrossings <- function(panel) {
    crosser <- matrix(0,nrow=dim(panel)[1],ncol=dim(panel)[2])
    for (i in 1:dim(panel)[2]) {
        crosser[,i][which(panel[,i]>0)] <- 1
        crosser[,i][which(panel[,i]<=0)] <- -1
    }
    zeros <- rep(0,dim(panel)[2])
    crosserReg <- rbind(zeros,crosser)
    crosserShift <- rbind(crosser,zeros)
    crosserDiff <- crosserReg + crosserShift
    crossings <- c(length(which(crosserDiff[,1]==0)),length(which(crosserDiff[,2]==0)),length(which(crosserDiff[,3]==0)),length(which(crosserDiff[,4]==0)),length(which(crosserDiff[,5]==0)),length(which(crosserDiff[,6]==0)))
    names(crossings) <- c("acc.x.zerocrossings","acc.y.zerocrossings","acc.z.zerocrossings","rotr.x.zerocrossings","rotr.y.zerocrossings","rotr.z.zerocrossings")
    return(crossings)
}

meanCrossings <- function(panel) {
    panelmean <- colMeans(panel)
    crosser <- matrix(0,nrow=dim(panel)[1],ncol=dim(panel)[2])
    for (i in 1:dim(panel)[2]) {
        crosser[,i][which(panel[,i]>panelmean[i])] <- 1
        crosser[,i][which(panel[,i]<=panelmean[i])] <- -1
    }
    zeros <- rep(0,dim(panel)[2])
    crosserReg <- rbind(zeros,crosser)
    crosserShift <- rbind(crosser,zeros)
    crosserDiff <- crosserReg + crosserShift
    crossings <- c(length(which(crosserDiff[,1]==0)),length(which(crosserDiff[,2]==0)),length(which(crosserDiff[,3]==0)),length(which(crosserDiff[,4]==0)),length(which(crosserDiff[,5]==0)),length(which(crosserDiff[,6]==0)))
    names(crossings) <- c("acc.x.meancrossings","acc.y.meancrossings","acc.z.meancrossings","rotr.x.meancrossings","rotr.y.meancrossings","rotr.z.meancrossings")
    return(crossings)
}

rangeDiffs <- function(panel) {
    diffs <- c(max(range(panel[,1]))-min(range(panel[,1])),max(range(panel[,2]))-min(range(panel[,2])),max(range(panel[,3]))-min(range(panel[,3])),max(range(panel[,4]))-min(range(panel[,4])),max(range(panel[,5]))-min(range(panel[,5])),max(range(panel[,6]))-min(range(panel[,6])))
    names(diffs) <- c("acc.x.rangediff","acc.y.rangediff","acc.z.rangediff","rotr.x.rangediff","rotr.y.rangediff","rotr.z.rangediff")
    return(diffs)
}

elementRanges <- function(panel) {
    ranges <- c(max(range(panel[,1])),min(range(panel[,1])),max(range(panel[,2])),min(range(panel[,2])),max(range(panel[,3])),min(range(panel[,3])),max(range(panel[,4])),min(range(panel[,4])),max(range(panel[,5])),min(range(panel[,5])),max(range(panel[,6])),min(range(panel[,6])))
    names(ranges) <- c("acc.x.max","acc.x.min","acc.y.max","acc.y.min","acc.z.max","acc.z.min","rotr.x.max","rotr.x.min","rotr.y.max","rotr.y.min","rotr.z.max","rotr.z.min")
    return(ranges)
}

enmo <- function(panel) {
    enmo <- (sqrt(rowSums(cbind(panel[3]^2,panel[4]^2,panel[5]^2)))-9.80665)/9.80665
    names(enmo) <- c("enmo")
    return(enmo)
}

# creates a full-size label vector from a panel and event list
createLabel <- function(panel,events) {
    events.full <- rep("Other",length(panel[,1]))
    for (i in 1:length(events$events$type)) {
        events.full[which(panel$time>=events$events$startTime[i]&panel$time<=events$events$endTime[i])] <- events$events$type[i]
    }
    return(events.full)
}

# shifts a binary vector 1 observation forward; (1,1,0,0) becomes (0,1,1,0)
shiftOneForward <- function(bvector) {
    bvector.shifted <- rep(0,(length(bvector)+1))
    bvector.shifted[2:length(bvector.shifted)] <- bvector
    bvector.shifted <- bvector.shifted[1:(length(bvector.shifted)-1)]

    return(bvector.shifted)
}

# creates a stringified JSON line with events from a prediction vector and panel
createEventJSON <- function(panel,expand.label) {
    event.binary <- rep(0,length(expand.label))
    event.binary <- ifelse(expand.label!="Other",1,0)
    event.binary.shifted <- shiftOneForward(event.binary)

    transitions <- event.binary - event.binary.shifted #+1 is start, -1 is end. start and end are shifted one forward from the truth.

    eventJSON <- matrix(nrow=length(which(transitions==1)),ncol=3)

    eventJSON[,1] <- expand.label[which(transitions==1)]
    eventJSON[,2] <- panel$time[which(transitions==1)]
    eventJSON[,3] <- panel$time[which(transitions==-1)-1]

    colnames(eventJSON) <- c("type","startTime","endTime")
    eventJSON <- as.data.frame(eventJSON)

    return(eventJSON)
}

# expands a feature-size prediction vector to a vector of panel length
labelExpand <- function(panel,label) {
	expand.label <- rep("Other",length(panel[,1]))
	expand.factor <- floor(length(panel[,1])/length(label))

	for(i in 0:(length(label)-1)) {
		expand.label[((i*expand.factor)+1):(expand.factor*(i+1))] <- as.character(label[i+1])
	}

	return(expand.label)
}

# shrinks a full-size label vector to length of feature vector
labelShrink <- function(panel,label) {
	shrunk.label<-rep("Other",length(panel[,1]))
	shrink.factor<-floor(length(label)/length(panel[,1]))

	for(i in 0:length(panel[,1])-1) {
		events <- table(label[((i*shrink.factor)+1):(shrink.factor*(i+1))])
        mostCommon <- names(which.max(events))
        shrunk.label[i+1] <- mostCommon
	}

	return(shrunk.label)
}

# converts a matrix of lists to a matrix of numerics
listToMatrix <- function(panel.list) {
    panel.matrix <- matrix(data=NA,nrow=dim(panel.list)[1],ncol=dim(panel.list)[2])
    for (i in 1:ncol(panel.list)) {
        panel.matrix[,i] <- c(as.numeric(panel.list[,i]))
    }
    colnames(panel.matrix) <- colnames(panel.list)

    return(panel.matrix)
}

features <- function(panel){
    n <- length(panel[,3])
    win.length <- 100
    nwindows <- floor(n/win.length)
    feature.panel <- list()

    for (i in 0:(nwindows-1)) {
        write(paste("Window", i),stderr())
        window.panel <- cbind(panel$acceleration.x[(i*win.length+1):(i*win.length+win.length)],panel$acceleration.y[(i*win.length+1):(i*win.length+win.length)],panel$acceleration.z[(i*win.length+1):(i*win.length+win.length)],panel$rotationrate.x[(i*win.length+1):(i*win.length+win.length)],panel$rotationrate.y[(i*win.length+1):(i*win.length+win.length)],panel$rotationrate.z[(i*win.length+1):(i*win.length+win.length)])
        feature.1 <- colMeans(window.panel)
        names(feature.1) <- c("mean.acc.x","mean.acc.y","mean.acc.z","mean.rotr.x","mean.rotr.y","mean.rotr.z")
        feature.2 <- zeroCrossings(window.panel)
        feature.3 <- meanCrossings(window.panel)
        feature.4 <- rangeDiffs(window.panel)
        feature.5 <- elementRanges(window.panel)
        feature.6 <- enmo(window.panel)
        feature.row <- c(feature.1,feature.2,feature.3,feature.4,feature.5,feature.6)
        feature.panel <- rbind(feature.panel,feature.row)
    }

return(feature.panel)
}


# 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;
}


# Script to composite surface reflectance into a cloud-free "map" and calculate vegetation indices

library(sf)
library(lubridate)
source("pixel-based/utils/load-sampling-data.r")
source("pixel-based/utils/ProbaVDataDirs.r")
source("pixel-based/utils/db-io.r")

# Load data and dates
InputDB = "../data/pixel-based/timeseries/timeseries-cloudfree.gpkg"
TempDB = "../data/pixel-based/timeseries/composites-intermediate.gpkg"
VIDB = "../data/pixel-based/timeseries/VI-TS.gpkg"
OutputDB = "../data/pixel-based/timeseries/composites.gpkg"

Dates = LoadRawDataDirs()$date
ColDates = paste0("X", gsub("-", "", Dates))
VIs = c("NDMI", "OSAVI", "EVI", "NIRv")
seasons = c("year", "spring", "summer", "autumn", "winter")
XYs = st_read(InputDB, "RADIOMETRY-1", query="SELECT X, Y, geom FROM 'RADIOMETRY-1'")

# There must be a nicer way to do this, but I can't think of any
Subsetter = function(VI, Band)
{
    VIMatrix = LoadVIMatrix(Tile, VI, Band, DataDir=DataDir) # Load the VI matrix from file
    VIMatrix = VIMatrix[,StartIndex:EndIndex] # Subset to summer 2016
    if (length(VIMatrix) > 0 && is.null(dim(VIMatrix)))
        VIMatrix = t(as.matrix(VIMatrix))

    stopifnot(nrow(VIMatrix) == length(MaxNDVIIdx))

    # Get the value at the highest NDVI time
    Result = c()
    for (i in 1:nrow(VIMatrix))
    {
        ResultIndex = MaxNDVIIdx[i]
        Result = c(Result, ifelse(is.na(ResultIndex), NA, VIMatrix[i, ResultIndex]))
    }
    names(Result) = rownames(VIMatrix)
    return(Result)
}

ScaleNDVI = function(NDVI){return((NDVI - 20) / 250)}
OSAVI = function(RED, NIR, BLUE=NULL, SWIR=NULL){return(1.16 * ((NIR-RED)/(NIR+RED+0.16)))}
NDMI = function(RED=NULL, NIR, BLUE=NULL, SWIR){return((NIR-SWIR)/(NIR+SWIR))}
EVI = function(RED, NIR, BLUE, SWIR=NULL){return(2.5*((NIR-RED)/((NIR + 6*RED - 7.5*BLUE)+1)))}
NIRv = function(RED, NIR, BLUE=NULL, SWIR=NULL){((NIR-RED) / (NIR+RED))*NIR}

# Subset input to the specified year/season smartly
SeasonMask = function(dfrow, type=c("year", "spring", "summer", "autumn", "winter"), dates=Dates)
{
    stopifnot(length(dfrow) == length(dates))

    type = match.arg(type)
    DOY = yday(dates)
    KeepIdx = switch(type, year=rep(TRUE, length(dates)),
        spring=DOY >= 60 & DOY <= 151,
        summer=DOY > 151 & DOY <= 243,
        autumn=DOY > 243 & DOY <= 334,
        winter=DOY < 60  | DOY > 334)
    KeepIdxThreeYears = KeepIdx & year(dates) < 2017

    MaskedRow = dfrow
    MaskedRow[!KeepIdxThreeYears] = NA
    if (all(is.na(MaskedRow))) # Do we have at least one observation? If not, use whole time series
    {
        MaskedRow = dfrow
        MaskedRow[!KeepIdx] = NA
    }

    return(MaskedRow)
}

# Utility iterator function around SeasonMask()
SMMeanMedian = function(x, ...)
{
    i = SeasonMask(x, ...)
    return(c(Mean=mean(i, na.rm=TRUE), Median=median(i, na.rm=TRUE)))
}

SMVIStats = function(x, ...)
{
    i = SeasonMask(x, ...)
    return(c(mean=mean(i, na.rm=TRUE),
        median=median(i, na.rm=TRUE),
        p80=quantile(i, na.rm=TRUE, probs=0.80),
        p20=quantile(i, na.rm=TRUE, probs=0.20),
        IQR=IQR(i, na.rm=TRUE)
        ))
}

# Should be fast enough to not need parallelisation, but hey, why not
#registerDoParallel(cores=4)
#Covariates = foreach(Tile=iter(TileList), .combine=rbind, .inorder=FALSE, .multicombine=TRUE) %do%
#{
    NDVIMatrix = st_read(InputDB, "NDVI")
    NDVIMatrix = RunSFFunction(NDVIMatrix, ScaleNDVI, select=ColDates)

    # Get mean NDVI over the whole time series
    MeanNDVI = ApplySF(NDVIMatrix, mean, na.rm=TRUE, select=ColDates)
    NDVILow = ApplySF(NDVIMatrix, quantile, na.rm=TRUE, probs=0.25, select=ColDates)
    NDVIHigh = ApplySF(NDVIMatrix, quantile, na.rm=TRUE, probs=0.75, select=ColDates)
    NDVIIQR = ApplySF(NDVIMatrix, IQR, na.rm=TRUE, select=ColDates)

    # Get date of highest NDVI, that will be the one that we use for the other bands too
    # The function is which.max that on all NAs returns NA rather than integer(0)
    #MaxNDVIIdx = ApplySF(NDVIMatrix, function(x){a=which.max(x); return(ifelse(length(a)<1, NA, a))}, select=ColDates)

    RadiometryMatrices = list(Red=st_read(InputDB, "RADIOMETRY-1"),
        NIR = st_read(InputDB, "RADIOMETRY-2"),
        Blue = st_read(InputDB, "RADIOMETRY-3"),
        SWIR = st_read(InputDB, "RADIOMETRY-4"))

    for (season in seasons)
    {
        # Composite all four bands, mean and median of all three years
        RadiometryYear = lapply(RadiometryMatrices, ApplySF, SMMeanMedian, select=ColDates, type=season)
        gc(TRUE)
        # Combine into an sf again
        RadYearSF = Reduce(cbind, RadiometryYear)
        RadYearSF = RadYearSF / 2000 # Convert to real units
        colnames(RadYearSF) = paste(rep(names(RadiometryYear), each=2), colnames(RadYearSF), sep=".")
        RadYearSF = cbind(RadiometryMatrices$Red[,c("X", "Y")], RadYearSF)
        # Write the output
        st_write(RadYearSF, TempDB, season)
        rm(RadiometryYear, RadYearSF)
        gc(TRUE)
    }

    rm(RadiometryMatrices)
    gc(TRUE)
    XYs = st_read(InputDB, "RADIOMETRY-1", query="SELECT X, Y, geom FROM 'RADIOMETRY-1'")
    # Calculate VIs
    for (season in seasons)
    {
        SeasonSF = st_read(TempDB, season)
        for (statistic in c("Mean", "Median"))
        {
            RadiometryInputs = list(RED=SeasonSF[[paste0("Red.", statistic)]],
                    NIR=SeasonSF[[paste0("NIR.", statistic)]],
                    BLUE=SeasonSF[[paste0("Blue.", statistic)]],
                    SWIR=SeasonSF[[paste0("SWIR.", statistic)]])
            for (VI in c("NDMI", "OSAVI", "EVI", "NIRv"))
            {
                VI_stat = do.call(VI, RadiometryInputs)
                SeasonSF = cbind(SeasonSF, VI_stat)
                names(SeasonSF)[length(SeasonSF)-1] = paste(VI, statistic, sep=".")
            }
        }
        st_write(SeasonSF, VIDB, season, delete_layer=TRUE)
    }

# Calculate VIs first
RadiometryMatrices = list(RED=as.matrix(as.data.frame(st_read(InputDB, "RADIOMETRY-1"))[,ColDates]),
                        NIR = as.matrix(as.data.frame(st_read(InputDB, "RADIOMETRY-2"))[,ColDates]),
                        BLUE = as.matrix(as.data.frame(st_read(InputDB, "RADIOMETRY-3"))[,ColDates]),
                        SWIR = as.matrix(as.data.frame(st_read(InputDB, "RADIOMETRY-4"))[,ColDates]))

for (VI in VIs)
{
    VI_stat = do.call(VI, RadiometryMatrices)
    st_write(cbind(XYs, VI_stat), VIDB, VI)
}

rm(VI_stat)
gc(TRUE)

# Run covar calculation.

for (VI in VIs)
{
    VITSMatrix = as.matrix(as.data.frame(st_read(VIDB, VI))[,ColDates])
    for (season in seasons)
    {
        VICovars = t(pbapply(VITSMatrix, 1, SMVIStats, type=season))
        st_write(cbind(XYs, VICovars), TempDB, paste(VI, season, sep="."), delete_layer=TRUE)
    }
}
rm(VITSMatrix, VICovars)
gc(TRUE)

# Merge it all into one big table.

CompositesSF = NULL
for (VI in VIs)
{
    for (season in seasons)
    {
        ID = paste(VI, season, sep=".")
        VISF = st_read(TempDB, ID)
        VIDF = as.matrix(as.data.frame(VISF)[,!names(VISF) %in% c("X", "Y", "geom")])
        colnames(VIDF) = paste(ID, colnames(VIDF), sep=".")
        if (is.null(CompositesSF)) {
            CompositesSF = cbind(VISF[,c("X", "Y")], VIDF)
        } else {
            CompositesSF = cbind(CompositesSF, VIDF)
        }
    }
}
st_write(CompositesSF, OutputDB)

# Input: matrices of each band representing time series
# Output: 5 versions of each VI: median, summer median, winter median, autumn median, spring median\


#' 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)


library(nnet)
library(caret)

set.seed(1433)

churn <- get(load("churn.RData"))
colnames(churn)

ind <- sapply(churn, is.numeric)
churn[ind] <- lapply(churn[ind], scale)

test_churn <- churn[4001:5000,]
churn <- churn[1:4000,]

drops <- c("state")
churn <- churn[,!(names(churn) %in% drops)]
test_churn <- test_churn[,!(names(test_churn) %in% drops)]

train_control <- trainControl(method = "repeatedcv", number = 10, repeats = 5)

errors <- function (model)
{
  options(digits=4)
  p1 <- as.factor(predict (model, type="class"))
  t1 <- table(p1,churned)
  cat ("Train = ", 100*(1-sum(diag(t1))/4000),"%\n")
  p2 <- as.factor(predict (model, newdata=test_churn, type="class"))
  t2 <- table(p2,test_churn$churned)
  cat ("Test = ", 100*(1-sum(diag(t2))/1000),"%\n")
}

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

# size 10 decay 0.1

model.nnet <- nnet(churned ~., data = churn, size=10, maxit=500, decay=0.1)
summary(model.nnet)
errors(model.nnet)

# The time elapsed in my computer is 110 seconds (1 min 50 secs) per 5 times 10 fold CV and 10 hidden

#############################################
# 10 hidden neurons with different regularizations

(decays <- 10^seq(-2,0,by=0.2))

start_time <- Sys.time()
model.10CV <- train(churned ~., data = churn, method='nnet', maxit = 500, trace = FALSE,
                        tuneGrid = expand.grid(.size=10,.decay=decays), trControl=train_control)
end_time <- Sys.time()

end_time - start_time

# Results
model.10CV$results
model.10CV$bestTune

#Time difference of 21.17 mins
#size   decay Accuracy  Kappa AccuracySD KappaSD
#1    10 0.01000   0.9293 0.6836    0.01326 0.06324
#2    10 0.01585   0.9333 0.7028    0.01414 0.06348
#3    10 0.02512   0.9375 0.7177    0.01391 0.06770
#4    10 0.03981   0.9409 0.7333    0.01155 0.05496
#5    10 0.06310   0.9385 0.7214    0.01271 0.06061
#6    10 0.10000   0.9385 0.7202    0.01423 0.06667
#7    10 0.15849   0.9401 0.7259    0.01274 0.06124
#8    10 0.25119   0.9395 0.7222    0.01303 0.06368
#9    10 0.39811   0.9381 0.7131    0.01215 0.05995
#10   10 0.63096   0.9346 0.6907    0.01052 0.05364
#11   10 1.00000   0.9314 0.6672    0.01109 0.05812

# 0.04 and 0.16 seem the best options
# Choices between 0.04 and 0.25 are all good choices

##########################################
# 20 hidden neurons with different regularizations
(decays <- 10^seq(-1.5,0.5,by=0.2))

start_time <- Sys.time()
model.10CV <- train(churned ~., data = churn, method='nnet', maxit = 500, trace = FALSE,
                    tuneGrid = expand.grid(.size=20,.decay=decays), trControl=train_control)
end_time <- Sys.time()

end_time - start_time

# Results
model.10CV$results
model.10CV$bestTune

#Time difference of 54.74 mins
#size   decay Accuracy  Kappa AccuracySD KappaSD
#1    20 0.03162   0.9039 0.5962   0.013308 0.05057
#2    20 0.05012   0.9125 0.6262   0.012697 0.05258
#3    20 0.07943   0.9173 0.6371   0.011487 0.05240
#4    20 0.12589   0.9265 0.6732   0.012837 0.06024
#5    20 0.19953   0.9281 0.6707   0.011827 0.05684
#6    20 0.31623   0.9339 0.6960   0.011250 0.05434
#7    20 0.50119   0.9348 0.6945   0.008970 0.04621
#8    20 0.79433   0.9345 0.6884   0.009543 0.04734
#9    20 1.25893   0.9319 0.6656   0.009551 0.05366
#10   20 1.99526   0.9248 0.6181   0.008358 0.05083
#11   20 3.16228   0.9134 0.5401   0.008598 0.05454

##########################################
# 7 hidden neurons with different regularizations
(decays <- 10^seq(-2.25,-0.25,by=0.2))

start_time <- Sys.time()
model.10CV <- train(churned ~., data = churn, method='nnet', maxit = 500, trace = FALSE,
                    tuneGrid = expand.grid(.size=7,.decay=decays), trControl=train_control)
end_time <- Sys.time()

end_time - start_time

# Results
model.10CV$results
model.10CV$bestTune

#Time difference of 12.82 mins
#size    decay Accuracy  Kappa AccuracySD KappaSD
#1     7 0.005623   0.9326 0.6933   0.015774 0.06809
#2     7 0.008913   0.9386 0.7177   0.011933 0.05711
#3     7 0.014125   0.9399 0.7258   0.012402 0.05654
#4     7 0.022387   0.9410 0.7298   0.012361 0.06242
#5     7 0.035481   0.9396 0.7238   0.012444 0.05973
#6     7 0.056234   0.9446 0.7456   0.011643 0.05516
#7     7 0.089125   0.9434 0.7418   0.011603 0.05426
#8     7 0.141254   0.9427 0.7353   0.010459 0.05049
#9     7 0.223872   0.9408 0.7270   0.008622 0.04285
#10    7 0.354813   0.9365 0.7002   0.010644 0.05111
#11    7 0.562341   0.9368 0.7005   0.007458 0.03843

# Size 10 optimal decay 0.04
model.nnet <- nnet(churned ~., data = churn, size=7, maxit=500, decay=0.056)
summary(model.nnet)
errors(model.nnet)


# Compare means with Kruskal-Wallis test (nonparametric, because non-normal distribution)

data <- read.csv('../../results/probabilities/data_all.csv', sep = ';')

# Means
aggregate(data$time, list(data$combination), median)
# 1 combination_0  838.0
# 2 combination_1  773.5
# 3 combination_2  686.0
# 4 combination_3  635.5
# 5 combination_4  604.5
# 6 combination_5  653.5
# 7 combination_6  850.5
# 8 combination_7 1071.5

#boxplot(time ~ combination, data = data, ylab="Exec (ms)", xlab="Combination")

# H0: No statistical difference between combinations
kruskal.test(time ~ combination, data = data)
# p: 0.184
# => Accept H0, equal means


library(igraph)
library(ggplot2)
#library(sna)
#library(network)

g = graph.data.frame(d = Cit.HepPh.WithDates[,c(1,3)], directed = T)

dg_in = degree(g,mode="in")
percent_in = degree.distribution(graph=g,mode="in")

nodes<-function(degree){
  attributes(dg_in[dg_in > degree])$names
}
wellcited<-nodes(6)
length(wellcited)

wellcitedpaperYear<-data.frame(year=1992:2002,paperCount=0)
dateOfPaper <- function(paperNodeId){
  cit.HepPh.dates.Unique[(cit.HepPh.dates.Unique$V1==paperNodeId),]$V2[1]
}
for(i in 1:length(wellcited)){
  year<-unlist(strsplit(as.character(dateOfPaper(wellcited[i])),split='-',fixed = TRUE))[1]
  wellcitedpaperYear[wellcitedpaperYear$year==year,]$paperCount <-
    wellcitedpaperYear[wellcitedpaperYear$year==year,]$paperCount+1
}

myplot<-ggplot(wellcitedpaperYear,aes(x=as.character(year),y=paperCount,fill=year))
myplot+geom_bar(stat="identity")+geom_point()+
  geom_text(aes(label=paperCount),hjust=0.5, vjust=-0.5 )+
  labs(x='year', y='WellcitedpaperCount')


doors_puzzle <- function(ndoors=100,passes=100) {
names(which(table(unlist(sapply(1:passes, function(X) seq(0, ndoors, by=X)))) %% 2 == 1))
}

doors_puzzle()


#!/usr/bin/Rscript
#
# Select the best ARIMA model for Retail Forecasting Benchmark - OrangeJuice_Pt_3Weeks_Weekly
#
# This script can be executed with the following command from TSPerf directory
#                         Rscript <submission dir>/model_selection.r
# It outputs a csv file containing the orders of the best ARIMA models selected by auto.arima
# function in R package forecast.

# Import packages
library(dplyr)
library(tidyr)
library(forecast)

# Define parameters
NUM_ROUNDS <- 12
TRAIN_START_WEEK <- 40
TRAIN_END_WEEK_LIST <- seq(135, 157, 2)

# Paths of the training data and submission folder
DATA_DIR <- './retail_sales/OrangeJuice_Pt_3Weeks_Weekly/data'
TRAIN_DIR <- file.path(DATA_DIR, 'train')
SUBMISSION_DIR <- file.path(dirname(DATA_DIR), 'submissions', 'ARIMA')

#### Select ARIMA model for every store-brand based on 1st-round training data ####
print('Selecting ARIMA models')
arima_model_all <- list()

select_arima_model <- function(train_sub) {
  # Selects the best ARIMA model for the time series of each store-brand.
  #
  # Args:
  #   train_sub (Dataframe): Training data of a certain store-brand
  #
  # Returns:
  #   arima_order_df (Dataframe): Configuration of the best ARIMA model
  cur_store <- train_sub$store[1]
  cur_brand <- train_sub$brand[1]
  train_ts <- ts(train_sub[c('logmove')], frequency = 52)
  fit_arima <- auto.arima(train_ts)
  arima_order <- arimaorder(fit_arima)
  arima_order_df <- data.frame(store = cur_store,
                               brand = cur_brand,
                               seasonal = length(arima_order) > 3,
                               p = arima_order['p'],
                               d = arima_order['d'],
                               q = arima_order['q'],
                               P = arima_order['P'],
                               D = arima_order['D'],
                               Q = arima_order['Q'],
                               m = arima_order['Frequency'])
}

r = 1
print(paste0('---- Round ', r, ' ----'))
# Import training data
train_df <- read.csv(file.path(TRAIN_DIR, paste0('train_round_', as.character(r), '.csv')))

# Create a dataframe to hold all necessary data
store_list <- unique(train_df$store)
brand_list <- unique(train_df$brand)
week_list <- TRAIN_START_WEEK:TRAIN_END_WEEK_LIST[r]
data_grid <- expand.grid(store = store_list,
                          brand = brand_list,
                          week = week_list)
train_filled <- merge(data_grid, train_df,
                      by = c('store', 'brand', 'week'),
                      all.x = TRUE)
train_filled <- train_filled[, c('store','brand','week','logmove')]

# Fill missing logmove
train_filled <-
  train_filled %>%
  group_by(store, brand) %>%
  arrange(week) %>%
  fill(logmove) %>%
  fill(logmove, .direction = 'up')

# Select ARIMA models
arima_model_all <-
  train_filled %>%
  group_by(store, brand) %>%
  do(select_arima_model(.))

# Combine and save model selection results
write.csv(arima_model_all, file.path(SUBMISSION_DIR, 'hparams.csv'), row.names = FALSE)


W = 10
WeightArray = c(5,2,4,6)
ValueArray = c(18,9,12,25)
DataKnap<-data.frame(WeightArray,ValueArray)

BestValue = 0
ItemsSelected = c()
TempWeights<-c()
TempValues<-c()

for(i in 1:4){
  CombWeights<-as.data.frame(combn(DataKnap[,1], i))
  CombValues<-as.data.frame(combn(DataKnap[,2], i))
  SumWeights<-colSums(CombWeights)
  SumValue<-colSums(CombValues)
  TempWeights<-which(SumWeights<=W)
    if(length(TempWeights) != 0){
      TempValues<-SumValue[TempWeights]
      BestValue<-max(TempValues)
      Index<-which((TempValues)==BestValue)
      MaxIndex<-TempWeights[Index]
      MaxVW<-CombWeights[, MaxIndex]
      j=1
      while (j<=i){
        ItemsSelected[j]<-which(DataKnap[,1]==MaxVW[j])
        j=j+1
      }
    }
  }
list(value=round(BestValue),elements=ItemsSelected)


print.ivmodel <- function(x, ...){
  ivmodel<-x
### print formula
  cat("\nCall:\n", paste(deparse(ivmodel$call), sep = "\n", collapse = "\n"),
      "\n", sep = "")
  cat("sample size: ", ivmodel$n, "\n", sep="")

### first stage regression result
  cat(rep("_", 30), "\n")
  cat("\nFirst Stage Regression Result:\n\n")

  SSM=c(sum(qr.fitted(ivmodel$ZadjQR, ivmodel$Dadj)^2))
  SST=sum(ivmodel$Dadj^2)
  SSE=SST-SSM
  DM=ivmodel$L
  DE=ivmodel$n-ivmodel$p-ivmodel$L
  DT=DM+DE

  Fstat=SSM/SSE*DE/DM
  pval=1-pf(Fstat, df1=DM, df2=DE)
  RSquare=SSM/SST
  adjRSquare=1-(1-RSquare)*DT/DE
  RMSE=sqrt(SSE/DE)

  cat("F=", Fstat, ", df1=", DM, ", df2=", DE, ", p-value is ", format.pval(pval), "\n", sep="")
  cat("R-squared=", RSquare, ",   Adjusted R-squared=", adjRSquare, "\n", sep="")
  cat("Residual standard error: ", RMSE, " on ", DT, " degrees of freedom\n", sep="")

### Sargan test
  if(ivmodel$L>1){

  cat(rep("_", 30), "\n")
  cat("\nSargan Test Result:\n\n")

  TSLS=sum(ivmodel$Dadj*qr.fitted(ivmodel$ZadjQR, ivmodel$Yadj))/
       sum(ivmodel$Dadj*qr.fitted(ivmodel$ZadjQR, ivmodel$Dadj))
  e=ivmodel$Yadj-ivmodel$Dadj*TSLS
  Sargan=sum(qr.fitted(ivmodel$ZadjQR, e)^2)/(sum(e^2)/length(e))
  pval=1-pchisq(Sargan, df=ivmodel$L-1)

  cat("Sargan Test Statistics=", Sargan, ", df=", ivmodel$L-1, ", p-value is ", format.pval(pval), "\n", sep="")

  }

### print TSLS, kClass, LIML, Fuller
  cat(rep("_", 30), "\n")
  cat("\nCoefficients of k-Class Estimators:\n\n")
  printCoefmat(coef(ivmodel), digits = max(3L, getOption("digits") - 3L))

### print AR, ARsens, CLR
  cat(rep("_", 30), "\n")
  cat("\nAlternative tests for the treatment effect under H_0: beta=", ivmodel$beta0, ".\n",sep = "")
  if(!is.null(ivmodel$AR)){
    cat("\nAnderson-Rubin test (under F distribution):\n")
	cat("F=", ivmodel$AR$Fstat, ", df1=", ivmodel$AR$df[1], ", df2=",
	    ivmodel$AR$df[2], ", p-value is ", format.pval(ivmodel$AR$p.value), "\n", sep="")
	cat(round((1-ivmodel$alpha)*100, digits=1), "percent confidence interval:\n",
	    ivmodel$AR$ci.info)
  }
  if(!is.null(ivmodel$ARsens)){
    cat("\n\nSensitivity analysis with deltarange [", ivmodel$ARsens$deltarange[1],
	    ", ", ivmodel$ARsens$deltarange[2], "]:\n")
	cat("non-central F=", ivmodel$ARsens$ncFstat, ", df1=", ivmodel$ARsens$df[1],
	    ", df2=", ivmodel$ARsens$df[2], ", ncp=", ivmodel$ARsens$ncp, ", p-value is ", format.pval(ivmodel$ARsens$p.value), "\n", sep="")
	cat(round((1-ivmodel$alpha)*100, digits=1), "percent confidence interval:\n",
	    ivmodel$ARsens$ci.info)
  }
  if(!is.null(ivmodel$CLR)){
    cat("\n\nConditional Likelihood Ratio test (under Normal approximation):\n")
	cat("Test Stat=", ivmodel$CLR$test.stat, ", p-value is ", format.pval(ivmodel$CLR$    p.value), "\n", sep="")
	cat(round((1-ivmodel$alpha)*100, digits=1), "percent confidence interval:\n",
	    ivmodel$CLR$ci.info)
  }
  cat("\n")
}


###########################################################################
#############Chapter 3 - Deep Learning with neuralnet######################
###########################################################################
library("neuralnet")
library(ISLR)

data = College
View(data)

max_data <- apply(data[,2:18], 2, max)
min_data <- apply(data[,2:18], 2, min)
data_scaled <- scale(data[,2:18],center = min_data, scale = max_data - min_data)

Private = as.numeric(College$Private)-1
data_scaled = cbind(Private,data_scaled)

index = sample(1:nrow(data),round(0.70*nrow(data)))
train_data <- as.data.frame(data_scaled[index,])
test_data <- as.data.frame(data_scaled[-index,])

n = names(train_data)
f <- as.formula(paste("Private ~", paste(n[!n %in% "Private"], collapse = " + ")))
deep_net = neuralnet(f,data=train_data,hidden=c(5,3),linear.output=F)
plot(deep_net)

predicted_data <- compute(deep_net,test_data[,2:18])
print(head(predicted_data$net.result))
predicted_data$net.result <- sapply(predicted_data$net.result,round,digits=0)

table(test_data$Private,predicted_data$net.result)

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


#install.packages("TSA")
library(forecast)
library(TSA)
library(zoo)
library(Metrics)
library(stats)
library(stringr)
#install.packages("WaveletANN")
library(WaveletANN)
#library(WaveletArima)

zero_reference = 18364 #Difference between 1970-01-01 to 2020-02-29
skip = 0
ts_size = 368     # Number of Sample/Timesteps in entire time series
tr_size = 228 #334 # Number of Samples/Timesteps in Training set 236
te_size = ts_size - tr_size # Number of Samples/Timesteps in Training set 140
horizons = 14  # Number of days to forecast ahead in the future
kt = 1       # Retraining Frequency (No. of Samples)
rt = 0         # Total Number of Retrainings Occured
p = 1          # Non-seasonal Auto-Regressive Order
d = 1          # Non-seasonal Differencing/
q = 0          # Non-seasonal Moving Average Order
PP = 3         # Seasonal Auto-Regressive Order
DD = 1         # Seasonal Differencing
QQ = 1         # Seasonal Moving Average Order
s = 7          # Seasonal Period

# Pull in the dataset from given URL
covid_data <- read.csv(file = "state_daily_deaths.csv")
cases_data <- read.csv(file = "state_daily_cases.csv")
state_list <- read.csv(file = "state_X_time.csv")$X
state_num = 0

state = "Ohio"
response_variable = ifelse(covid_data[[state]] <=0, 1, covid_data[[state]])
exog_variable = ifelse(cases_data[[state]] <=0, 1, cases_data[[state]])
smape_scores = matrix(data = NA, nrow = horizons, ncol = 22)
covid_ts <- zoo(response_variable, seq(as.Date("2020-04-13"), as.Date("2021-04-15"), by = "days"), frequency = 1)

country_test_data <- window(covid_ts, start = as.Date((tr_size+1) + zero_reference), end = as.Date(ts_size + zero_reference), frequency = 1)
xyz<- window(covid_ts, start = as.Date((tr_size+1) + zero_reference), end = as.Date(ts_size + zero_reference), frequency = 1)
country_forecast_matrix <- matrix(data = c(0), nrow = te_size, ncol = horizons)
forecast_matrix <- matrix(data = c(0), nrow = 14, ncol = te_size)
for(state in state_list){
  print(state)
  state_num = state_num + 1
  if(state_num != 46) {
    response_variable = ifelse(covid_data[[state]] <=0, 1, covid_data[[state]])
    exog_variable = ifelse(cases_data[[state]] <=0, 1, cases_data[[state]])
    smape_scores = matrix(data = NA, nrow = horizons, ncol = 22)
    covid_ts <- zoo(response_variable, seq(as.Date("2020-04-13"), as.Date("2021-04-15"), by = "days"), frequency = 1)
    exog_ts <- zoo(exog_variable, seq(as.Date("2020-04-13"), as.Date("2021-04-15"), by = "days"), frequency = 1)
    for (i in 1:te_size) {
      start = i + zero_reference
      model_data <- window(log(covid_ts), start = as.Date(start), end = as.Date(start + tr_size - 1), frequency = 1)
      exog_data <- window(log(exog_ts), start = as.Date(start), end = as.Date(start + tr_size - 1), frequency = 1)
      if (i == 1) {
        arima_model <- Arima(y = model_data, order = c(p, d, q), seasonal = list(order = c(PP, DD, QQ), period = s), method = "CSS")
      } else {
        if ((i %% kt) == 0) { #if iteration mod retrain frequency is 0, then it is time to retrain the model with new training data
          rt = rt + 1
          arima_model <- Arima(y = model_data, order = c(p, d, q), seasonal = list(order = c(PP, DD, QQ), period = s), method = "CSS")
        } else {
          arima_model <- Arima(y = model_data, model = arima_model, xreg=exog_data)

        }
      }
      #future <- forecast(arima_model, h = horizons,level = 0)
      newxreg = window(log(exog_ts), start = as.Date(start - horizons + tr_size), end = as.Date(start + tr_size - 1), frequency = 1)
      future <- forecast(arima_model, h = horizons, level = 0)

      forecasts <- future$mean
      for (k in 1:horizons) {
        if (k + i - 1 <= te_size) { # Condition to prevent overflow at the end of the test set;
          forecast_matrix[k, k+i-1] = forecasts[k]
        }
      }
    }
    test_data <- window(covid_ts, start = as.Date((tr_size+1) + zero_reference), end = as.Date(ts_size + zero_reference), frequency = 1)
    country_test_data = country_test_data + test_data
  }
  forecast_matrix2 <- t(forecast_matrix)
  forecast_matrix2 <- exp(forecast_matrix2)
  country_forecast_matrix = country_forecast_matrix + forecast_matrix2
}

country_test_data = country_test_data - xyz

country_forecast_matrix <- t(country_forecast_matrix)
for(i in 2:horizons){
  for(j in 1:i-1){
    country_forecast_matrix[i,j] = country_forecast_matrix[i-1,j]
  }

}
country_forecast_matrix <- t(country_forecast_matrix)
View(covid_data)

for (i in 1:horizons) {
  smape_scores[i, p] <- mean(abs((country_test_data - country_forecast_matrix[, i]) / (country_test_data + country_forecast_matrix[, i]))) * 200 #smape formula
  #smape_scores[i, p] <- mean(abs(test_data - forecast_matrix2[, i]))
  print(paste0("h=",i,",smape=",smape_scores[i,p]))
}
forecast_matrix2 <- t(forecast_matrix)
forecast_matrix2 <- exp(forecast_matrix2)

write.table(country_forecast_matrix,file="state_data_country_forecast_matrix.csv", sep = ",") # keeps the rownames
write.table(country_test_data,file="state_data_country_test_data.csv", sep = ",") # keeps the rownames

state_num = 0
forecast_matrix <- matrix(data = c(-1.2), nrow = ts_size, ncol = 52)
for(state in state_list){
  state_num = state_num + 1
  if(state_num != 46) {
    response_variable = ifelse(covid_data[[state]] <=0, 1, covid_data[[state]])
    covid_ts <- zoo(response_variable, seq(as.Date("2020-04-13"), as.Date("2021-04-15"), by = "days"), frequency = 1)
    in_sample_data <- window(log(covid_ts), start = as.Date(1 + zero_reference), end = as.Date(544 + zero_reference), frequency = 1)
    in_sample_model <- Arima(y=in_sample_data, order = c(p,d,q), seasonal = list(order=c(PP,DD,QQ),period=s), method="CSS")
    in_ts <- as.ts(in_sample_data)
    fitted_values <- in_ts - abs(in_sample_model$residuals)
    forecast_matrix[,state_num] = exp(fitted_values)

  }

}

forecast_matrix2 <- t(forecast_matrix)
forecast_matrix2 <- exp(forecast_matrix2)

write.table(forecast_matrix2,file="state_data_in_sample_forecast_matrix2.csv", sep = ",") # keeps the rownames

#In-sample Analysis
xreg_lag = 14
in_sample_data <- window(log(covid_ts), start = as.Date(1 + zero_reference), end = as.Date(544 + zero_reference), frequency = 1)
in_sample_exog <- window(log(exog_ts), start = as.Date(1 + zero_reference - xreg_lag), end = as.Date(544 + zero_reference - xreg_lag), frequency = 1)
in_ts <- as.ts(in_sample_data)
ex_ts <- as.ts(in_sample_exog)

in_sample_model <- Arima(y=in_sample_data, order = c(p,d,q), seasonal = list(order=c(PP,DD,QQ),period=s), method="CSS", xreg = in_sample_exog)
fitted_values <- in_ts - abs(in_sample_model$residuals)
in_sample_smape <- mean(abs(exp(in_ts) - exp(fitted_values)) / (abs(exp(in_ts)) + abs(exp(fitted_values)))) * 200
print(xreg_lag)
print(in_sample_smape)

plot(exp(fitted_values))
plot(exp(in_sample_data))
length(fitted_values)

write.table(exp(fitted_values) ,file="fitted_values_new_dataset.csv", sep = ",") # keeps the rownames
sum = 0.0
e <- exp(in_ts) - exp(fitted_values)
cnt = 0
for(i in 1:length(in_ts)){
  denom <- abs(exp(in_ts[i])) + abs(exp(fitted_values[i]))
  if(denom != 0){
    sum = sum + (abs(e[i]) / denom)
    cnt = cnt + 1
  }
}
print("In-Sample SMAPE:")
print(200 * sum/cnt)

#write.table(smape_scores,file="D:\\Courses\\7200-MSProject\\R\\test.txt") # keeps the rownames
#unlink("test.txt")