context("DO functions")
library("NSmetabolism")

test_that("Computing input mass flux", {
	upDO <- c(10, 8)
	upQ <- c(15, 20)
	latQ <- 5
	latDO <- 0

	# input checking
	expect_error(computeInputDOFlux(-1 * upQ, upDO, latQ, latDO))
	expect_error(computeInputDOFlux(upQ, -1 * upDO, latQ, latDO))
	expect_error(computeInputDOFlux(upQ, upDO, -1 * latQ, latDO))
	expect_error(computeInputDOFlux(upQ, upDO, latQ, -5))
	expect_error(computeInputDOFlux(upQ, upDO[1], latQ, latDO))

	# test with 0, 1, and two upstream neighbors
	expect_error(computeInputDOFlux(upQ, upDO, latQ, latDO), regex=NA)
	expect_error(computeInputDOFlux(upQ[1], upDO[1], latQ, latDO), regex=NA)
	expect_error(computeInputDOFlux(numeric(0), numeric(0), latQ, latDO), regex=NA)

	#higher discharge and DO concentration means higher flux
	expect_lt(computeInputDOFlux(upQ[1], upDO[1], latQ, latDO),
		computeInputDOFlux(upQ[1]*2, upDO[1], latQ, latDO))
	expect_lt(computeInputDOFlux(upQ[1], upDO[1], latQ, latDO),
		computeInputDOFlux(upQ[1], upDO[1]*2, latQ, latDO))

})

test_that("Advection", {
	dat <- c(Q = 10, area = 20, dx = 5)
	expect_error(computeAdvection(10, 10, dat), regex=NA)
	expect_gt(computeAdvection(10, 10, dat), computeAdvection(0, 10, dat))

	# input checking
	expect_error(computeAdvection(-10, 10, dat))
	expect_error(computeAdvection(10, -10, dat))
	dat['area'] <- -1
	expect_error(computeAdvection(10, 10, dat))
	dat[c('area', 'Q')] <- c(20, -2)
	expect_error(computeAdvection(10, 10, dat))
	dat[c('Q', 'dx')] <- c(10, -5)
	expect_error(computeAdvection(10, 10, dat))

})

test_that("Rearation flux produces sensible values", {
	T <- 20
	p <- 1025
	do <- 9
	k <- 2/(24*60)

	# input checking
	expect_error(kT(T, -5))
	expect_error(kT(T, c(k, 2*k)))
	expect_error(osat(c(T, T*2), p))

	# reference value for kT
	expect_equal(kT(T, k), 0.001477129, tol=1e-5)

	# reference value for Osat
	CstarO <- 10.084
	T <- 15
	P <- 1013.2500
	Patm <- 1
	ref <- CstarO * Patm
	expect_equal(osat(T, P), ref, tol=1e-3)

	## basic input checking
	expect_error(computeRF(c(T, T*2), p, do, k))
	expect_error(computeRF(T, p, do, c(k, 2*k)))
	expect_error(computeRF(T, p, -5, k))
	expect_error(computeRF(T, p, do, -2))
	expect_error(computeRF(T, -1, do, k))

	## DO below saturation
	expect_gt(computeRF(T, p, do, k), 0)

	## DO above saturation
	expect_lt(computeRF(T, p, 20, k), 0)
})

test_that("GPP and ER", {
	expect_error(computeGPP(-10, 5, 2))
	# vector sizes match
	expect_error(computeGPP(c(100, 120), 5, 2))

	# no light, no GPP
	expect_equal(computeGPP(0, 5, 2), 0)
	expect_equal(computeGPP(0, 5, NA), 0)

	# linear curves are equal no matter how we compute
	expect_equal(computeGPP(1000, 5, -Inf), computeGPP(1000, 5, NA))

	# GPP is positive when there is light
	expect_gt(computeGPP(1000, 5, 2), 0)
	expect_gt(computeGPP(1000, 5, NA), 0)

	# Linear curve is strictly greater than saturating
	expect_gt(computeGPP(1000, 5, NA), computeGPP(1000, 5, 2))

	# saturating curve saturates
	expect_gt(computeGPP(1000, 5, 2) - computeGPP(1, 5, 2),
		computeGPP(11000, 5, 2) - computeGPP(10001, 5, 2))

	# er24 must be negative
	expect_error(inSituER(15, 5))

	# at 20 degrees we should get the same value back
	expect_equal(inSituER(20, -5), -5, tol = 1e-2)

	# otherwise make sure ER is negative, and is 0 if er24 is 0
	expect_equal(inSituER(15, 0), 0)
	expect_lt(inSituER(15, -5), 0)

	# test using a vector of temps with one or more ERs
	expect_error(inSituER(c(5,10,15), c(-5, -6)))
	expect_error(inSituER(c(5,10,15), c(-5, -6, -10)), regex=NA)
	expect_error(inSituER(c(5,10,15), c(-5)), regex=NA)
})

# test_that("ddodt", {
# 	defaultParams <- c(lP1 = 10, lP2 = 5, k600 = 2/(24*60), ER24 = -10)
# 	defaultData <- c(Q = 20, area = 45, dx = 24, z = 1)
# 	defaultInputDOMass <- 9 * defaultData['Q']
# 	defaultDOPrev <- 8
# 	defaultlight <- 800
# 	defaultWaterTemp = 15
# 	defaultPressure = 1015

# 	# check for errors on invalid input
# 	pars <- defaultParams
# 	pars['ER24'] <- 5
# 	expect_error(dDOdt(pars, defaultData, defaultInputDOMass, defaultDOPrev, defaultlight,
# 		defaultWaterTemp, defaultPressure))
# 	data <- defaultData
# 	data['Q'] <- -10
# 	expect_error(dDOdt(defaultParams, data, defaultInputDOMass, defaultDOPrev, defaultlight,
# 		defaultWaterTemp, defaultPressure))
# 	data <- defaultData
# 	data['area'] <- -10
# 	expect_error(dDOdt(defaultParams, data, defaultInputDOMass, defaultDOPrev, defaultlight,
# 		defaultWaterTemp, defaultPressure))
# 	data <- defaultData
# 	data['dx'] <- -10
# 	expect_error(dDOdt(defaultParams, data, defaultInputDOMass, defaultDOPrev, defaultlight,
# 		defaultWaterTemp, defaultPressure))
# 	data['z'] <- -10
# 	expect_error(dDOdt(defaultParams, data, defaultInputDOMass, defaultDOPrev, defaultlight,
# 		defaultWaterTemp, defaultPressure))
# 	expect_error(dDOdt(defaultParams, defaultData, -10, defaultDOPrev, defaultlight,
# 		defaultWaterTemp, defaultPressure))
# 	expect_error(dDOdt(defaultParams, defaultData, defaultInputDOMass, -10, defaultlight,
# 		defaultWaterTemp, defaultPressure))
# 	expect_error(dDOdt(defaultParams, defaultData, defaultInputDOMass, defaultDOPrev, -10,
# 		defaultWaterTemp, defaultPressure))
# 	expect_error(dDOdt(defaultParams, defaultData, defaultInputDOMass, defaultDOPrev, defaultlight,
# 		defaultWaterTemp, -10))

# 	# no error on valid input
# 	expect_error(dDOdt(defaultParams, defaultData, defaultInputDOMass, defaultDOPrev,
# 		defaultlight, defaultWaterTemp, defaultPressure), regex = NA)
# 	# no light and no input means loss of oxygen
# 	pars <- defaultParams
# 	pars['k600'] <- 0
# 	expect_lt(dDOdt(pars, defaultData, 0, defaultDOPrev, 0, defaultWaterTemp, defaultPressure), 0)
# 	# lots of light OR lots of input and no respiration and output means increasing oxygen
# 	pars['ER24'] <- 0
# 	expect_gt(dDOdt(pars, defaultData, 0, 0, 1000, defaultWaterTemp,
# 		defaultPressure), 0)
# 	expect_gt(dDOdt(pars, defaultData, 50, 0, 0, defaultWaterTemp, defaultPressure), 0)

# })


# Check if RStudio is running to set the working directory to the script directory
# https://stackoverflow.com/questions/35986037/detect-if-an-r-session-is-run-in-rstudio-at-startup
is.na(Sys.getenv("RSTUDIO", unset = NA))
if (!is.na(Sys.getenv("RSTUDIO", unset = NA))) {
  # Get current directory
  current_dir <- dirname(rstudioapi::getSourceEditorContext()$path)
  # Set working directory to current directory (script directory)
  setwd(current_dir)
} else {
  # If sourced https://stackoverflow.com/questions/13672720/r-command-for-setting-working-directory-to-source-file-location-in-rstudio
  this.dir <- dirname(parent.frame(2)$ofile)
  setwd(this.dir)
}
# Include the excel helper functions
source("excelhelper.r")

# library for data manipulation
library(dplyr)
library(reshape2)

# Read the input files
diamonds<- getTable("diamonds")

# Then, we'll use the dcast function to get our data into the same pivot table format.
# we're taking the color, clarity, and price columns from the diamonds data frame,
# casting (pivoting) them out by color (rows) and clarity (columns),
# and calculating the average price for each combination.
pivot_table <- dcast(diamonds[,c('color','clarity','price')], color~clarity, mean)

# Write the result
writeResult(tablenames = list("result"=pivot_table))

# Signal the end of the process
done()

# free up all variables
rm(list=ls())


library(tidyverse)
library(rwththeme)
df <- read_rds("data.rds")

rwththeme()
mytheme <- theme_bw()

mytheme <- function(...){
  theme_bw(base_size=12, base_family="Helvetica Neue", ...) + theme(
      panel.background  = element_blank(),
      plot.background = element_blank()
      #panel.border = element_rect(size=0.75)
    )
}

df %>%
  select(age) %>%
  ggplot() +
  aes(age) +
  geom_histogram(bins = 30, fill = rwth.colorpalette()$blue) +
  labs(
    title = "The sample is of a very young age",
    subtitle = "Histogram of the age variable",
    x = "Age",
    y = "Frequency (absolute)",
    caption = "Histogram using 30 bins"
  ) +
  mytheme() +
  NULL

ggplot2::theme_set(mytheme())


rm(list = ls())
setwd(dirname(parent.frame(2)$ofile))

library(ggplot2)
library(xtable)
library(plyr)
library(dplyr)
library(tidyr)
library(readr)
library(kableExtra)
source('./_sequential_mnist_expand_name.r')
source('./_compute_summary.r')
source('./_plot_parameter.r')

best.range = 1000
alpha = 0.01

plot.label = paste0("Extrapolation length")
plot.x.breaks = c(1,seq(2,20,2))

best.model.step.fn = function (errors) {
  best.step = max(length(errors) - best.range, 0) + which.min(tail(errors, best.range))
  if (length(best.step) == 0) {
    return(length(errors))
  } else {
    return(best.step)
  }
}

first.solved.step = function (steps, errors, threshold) {
  index = first(which(errors < threshold))
  if (is.na(index)) {
    return(NA)
  } else {
    return(steps[index])
  }
}

safe.interval = function (alpha, vec) {
  if (length(vec) <= 1) {
    return(NA)
  }

  return(abs(qt((1 - alpha) / 2, length(vec) - 1)) * (sd(vec) / sqrt(length(vec))))
}

eps = expand.name(read_csv('../results/sequential_mnist_prod_reference.csv')) %>%
  gather(
    key="parameter", value="test.extrapolation.mse",
    metric.test.extrapolation.1.mse, metric.test.extrapolation.2.mse,
    metric.test.extrapolation.3.mse, metric.test.extrapolation.4.mse,
    metric.test.extrapolation.5.mse, metric.test.extrapolation.6.mse,
    metric.test.extrapolation.7.mse, metric.test.extrapolation.8.mse,
    metric.test.extrapolation.9.mse, metric.test.extrapolation.10.mse,
    metric.test.extrapolation.11.mse, metric.test.extrapolation.12.mse,
    metric.test.extrapolation.13.mse, metric.test.extrapolation.14.mse,
    metric.test.extrapolation.15.mse, metric.test.extrapolation.16.mse,
    metric.test.extrapolation.17.mse, metric.test.extrapolation.18.mse,
    metric.test.extrapolation.19.mse, metric.test.extrapolation.20.mse
  ) %>%
  rowwise() %>%
  mutate(
    parameter = extrapolation.loss.name.to.integer(parameter)
  ) %>%
  group_by(seed, parameter) %>%
  summarise(
    best.model.step = best.model.step.fn(metric.valid.mse),
    threshold = test.extrapolation.mse[best.model.step],
  ) %>%
  filter(seed %in% c(0,2,4,5,6,7,9)) %>% # seed 1, 3, and 8 did not solve it
  group_by(parameter) %>%
  summarise(
    threshold = mean(threshold) + qt(1 - alpha, 8) * (sd(threshold) / sqrt(n()))
  )

dat = expand.name(read_csv('../results/sequential_mnist_prod_long.csv')) %>%
  gather(
    key="parameter", value="test.extrapolation.mse",
    metric.test.extrapolation.1.mse, metric.test.extrapolation.2.mse,
    metric.test.extrapolation.3.mse, metric.test.extrapolation.4.mse,
    metric.test.extrapolation.5.mse, metric.test.extrapolation.6.mse,
    metric.test.extrapolation.7.mse, metric.test.extrapolation.8.mse,
    metric.test.extrapolation.9.mse, metric.test.extrapolation.10.mse,
    metric.test.extrapolation.11.mse, metric.test.extrapolation.12.mse,
    metric.test.extrapolation.13.mse, metric.test.extrapolation.14.mse,
    metric.test.extrapolation.15.mse, metric.test.extrapolation.16.mse,
    metric.test.extrapolation.17.mse, metric.test.extrapolation.18.mse,
    metric.test.extrapolation.19.mse, metric.test.extrapolation.20.mse
  ) %>%
  mutate(
    valid.interpolation.mse=metric.valid.mse,
    train.interpolation.mse=metric.train.mse
  ) %>%
  select(-metric.valid.mse, -metric.train.mse) %>%
  rowwise() %>%
  mutate(
    parameter = extrapolation.loss.name.to.integer(parameter)
  ) %>%
  merge(eps)

dat.last = dat %>%
  group_by(name, parameter) %>%
  summarise(
    threshold = last(threshold),
    best.model.step = best.model.step.fn(valid.interpolation.mse),
    interpolation.last = valid.interpolation.mse[best.model.step],
    extrapolation.last = test.extrapolation.mse[best.model.step],
    interpolation.step.solved = first.solved.step(step, valid.interpolation.mse, threshold),
    extrapolation.step.solved = first.solved.step(step, test.extrapolation.mse, threshold),
    sparse.error.max = sparse.error.max[best.model.step],
    solved = replace_na(test.extrapolation.mse[best.model.step] < threshold, FALSE),

    model = last(model),
    operation = last(operation),
    regualizer.z = last(regualizer.z),
    seed = last(seed),
    size = n()
  )

dat.last.rate = dat.last %>%
  group_by(model, operation, parameter, regualizer.z) %>%
  group_modify(compute.summary) %>%
  ungroup()

plot.by.regualizer.z = function (regualizer.z.show) {
  dat.plot = dat.last.rate %>%
    filter(
      (regualizer.z == regualizer.z.show & model %in% c('$\\mathrm{NAC}_{\\bullet,\\mathrm{NMU}}$', 'NMU')) |
      model %in% c('$\\mathrm{NAC}_{\\bullet}$', '$\\mathrm{NAC}_{\\bullet,\\sigma}$', 'LSTM', 'NALU')
    )

  p = plot.parameter(dat.plot, plot.label, plot.x.breaks)
  return(p)
}

p.with.R.z = plot.by.regualizer.z(1)
print(p.with.R.z)
ggsave('../paper/results/sequential_mnist_prod_long.pdf', p.with.R.z, device="pdf", width = 13.968, height = 5.7, scale=1.4, units = "cm")
ggsave('../paper/results/sequential_mnist_prod_long_short.pdf', p.with.R.z, device="pdf", width = 13.968, height = 5.1, scale=1.4, units = "cm")

p.without.R.z = plot.by.regualizer.z(0)
print(p.without.R.z)
ggsave('../paper/results/sequential_mnist_prod_long_ablation.pdf', p.without.R.z, device="pdf", width = 13.968, height = 5.7, scale=1.4, units = "cm")


########################################################
# The MIT License (MIT)
#
# Copyright (c) 2014 Florian D. Schneider & Sonia Kéfi
#
# Permission is hereby granted, free of charge, to any person obtaining a copy
# of this software and associated documentation files (the "Software"), to deal
# in the Software without restriction, including without limitation the rights
# to use, copy, modify, merge, publish, distribute, sublicense, and/or sell
# copies of the Software, and to permit persons to whom the Software is
# furnished to do so, subject to the following conditions:
#
# The above copyright notice and this permission notice shall be included in all
# copies or substantial portions of the Software.
#
# THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
# IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
# FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE
# AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
# LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,
# OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE
# SOFTWARE.
#
########################################################

### mussel bed model (Guichard et al 2003)

musselbed <- list()
class(musselbed) <- "ca_model"
musselbed$name <- "Mussel Disturbance Model"
musselbed$ref <- "Guichard et al 2003, American Naturalist, Vol. 161, pp. 889–904"
musselbed$states <- c("+", "0", "-")
musselbed$cols <- grayscale(3)
musselbed$parms <- list(
  r = 0.4, # recolonisation of empty sites dependent on local density
  d = 0.9, # probability of disturbance of occupied sites if at least one disturbed site
  delta = 0.01 # intrinsic disturbance rate
)
musselbed$update <- function(x_old, parms_temp, delta = 0.2, subs = 10, timestep = NA) {

  x_new <- x_old

  for(s in 1:subs) {

    parms_temp$rho_plus <- sum(x_old$cells == "+")/(x_old$dim[1]*x_old$dim[2]) # get initial vegetation cover
    parms_temp$localdisturbance <- count(x_old, "-") > 0  # any disturbance in neighborhood?
    parms_temp$localcover <- count(x_old, "+")/4 # any occupied in neighborhood?

    # 2 - drawing random numbers
    rnum <- runif(x_old$dim[1]*x_old$dim[2]) # one random number between 0 and 1 for each cell

    # 3 - setting transition probabilities

    if(parms_temp$rho_plus > 0) {
      recolonisation <- with(parms_temp, (r*localcover)*1/subs)

      disturbance <- with(parms_temp, (delta+d*localdisturbance)*1/subs)
      disturbance[disturbance > 1] <- 1
    } else {
      recolonisation <- 0
      disturbance <- 1
    }

    regeneration <- 1*1/subs

    # check for sum of probabilities to be inferior 1 and superior 0
    if(any(c(recolonisation, disturbance, regeneration) > 1 )) warning(paste("a set probability is exceeding 1 in  time step", timestep, "! decrease number of substeps!!!"))
    if(any(recolonisation < 0)) warning(paste("recolonisation falls below 0 in time step",timestep, "! balance parameters!!!"))
    if(any( disturbance < 0)) warning(paste("disturbance falls below 0 in time step",timestep, "! balance parameters!!!"))
    if(any(regeneration < 0)) warning(paste("regeneration falls below 0 in time step",timestep, "! balance parameters!!!"))

    # 4 - apply transition probabilities

    x_new$cells[which(x_old$cells == "0" & rnum <= recolonisation)] <- "+"
    x_new$cells[which(x_old$cells == "+"  & rnum <= disturbance)] <- "-"
    x_new$cells[which(x_old$cells == "-"   & rnum <= regeneration)] <- "0"

    # 5- store x_new as next x_old

    x_old <- x_new

  }

  ## end of single update call
  return(x_new)
}


## ---
## title: "Example to fit the function 'multiSidbFit'"
## author: " "
## date: "03/15/2021"
## ---

## imports
packs <- c('SoilR', 'sidb', 'yaml', 'parallel','R.utils')
sapply(packs, require, character.only = TRUE) ## be sure all the outputs are TRUE

## Function uploading
userLocation <- '/home/wilar/Documents' #Change location of the sidb folder
source.R <- file.path(userLocation, 'sidb/scripts/multiSidbFit')
sourceDirectory(source.R, modifiedOnly = TRUE, verbose = TRUE)

## Data-entry loading
path <- "/home/wilar/Documents/sidb/data/" ## set a correct file path
load_entries <- loadEntries(path)
db <- load_entries[["Crow2019a"]]

## Example 1
twopsFit_model <- multiSidbFit(db,
                       model = 'twopsFit',
                       ic.col = 1,
                       ts.col = 15:20,
                       inipars=c(0.05, 0.00001, 0.1, 0.01))

## Example 2
threeppFit_model <- multiSidbFit(db,
                    model = 'threeppFit',
                    ts.col = 2:10,
                    inipars=c(0.05, 0.01, 0.001, 0.1, 0.1))


library(data.table)
#N = 2^31 - 1
N = 2e9/8
K = 100

DT <- data.table(
  #id6 = sample(N/K, N, TRUE)                      # small groups (int)
  #,id3 = sample(sprintf("id%010d",1:(N/K)), N, TRUE),
  id4 = sample(K, N, TRUE)
  ,v1 =  sample(5, N, TRUE)                          # int in range [1,5
)

# group by id6
system.time(DT[, sum(v1), keyby = id4])
system.time(DT[, sum(v1), keyby = id4])
# group by id6
system.time(DT[, sum(v1), keyby = id6])
system.time(DT[, sum(v1), keyby = id6])

# pre-index id6
system.time(setkey(DT, id6))
system.time(DT[, sum(v1), keyby = id6])
system.time(DT[, sum(v1), keyby = id6])

# group by id6
system.time(DT[, .N, keyby = id6])
system.time(DT[, .N, keyby = id6])

# pre-index id6
system.time(setkey(DT, id6))
system.time(DT[, .N, keyby = id6])
system.time(DT[, .N, keyby = id6])

# group by id6
system.time(DT[, sum(v1),keyby = id6])
system.time(DT[, sum(v1),keyby = id6])

# pre-index id6
system.time(setkey(DT, id6))
system.time(DT[, sum(v1),keyby = id6])
system.time(DT[, sum(v1),keyby = id6])

# sort by id3 (strings)
system.time(DT[, sum(v1),keyby = id3])
system.time(DT[, sum(v1),keyby = id3])

# pre-index id3
system.time(setkey(DT, id3))
system.time(DT[, sum(v1),id3])
system.time(DT[, sum(v1),id3])

library(data.table)
library(ggplot2)
a <- fread("C:/Users/dzj/.julia/v0.6/FastGroupBy/hehe6.csv")

ggplot(a) + geom_line(aes(x=log(n), y=log(x1), color=algo))


# 3. faza: Vizualizacija podatkov

#zemljevid regij
place.regije$STATISTICNA.REGIJA[10] <- "Notranjsko-kraška"
place.regije$STATISTICNA.REGIJA[9] <- "Spodnjeposavska"

tmap_mode("view" )
slo1 <- uvozi.zemljevid("https://biogeo.ucdavis.edu/data/gadm3.6/shp/gadm36_SVN_shp.zip", "gadm36_SVN_1", encoding="UTF-8")
slo <- tm_shape(merge(slo1, place.regije,  by.x="NAME_1", by.y="STATISTICNA.REGIJA")) + tm_polygons("POVPRECNA.PLACA", title = "Povprečna plača (€)") +
  tm_text('NAME_1', size = 0.8)+ tm_view(text.size.variable = TRUE, view.legend.position = c("right", "bottom")) +
  tm_layout(title="Povprečna letna plača v vsaki regiji")

#grafi

#katera panoga v regiji ima maksimalno povprecno letno placo
max.place.v.regiji <- ggplot(place.max) + aes(x=STATISTICNA.REGIJA, y=MAX.LETNA.PLACA,fill=SKD.DEJAVNOST) + geom_col() +
  xlab("Regija") + theme(axis.text.x = element_text(size = 6, angle = 90, vjust = 0.5, hjust=1)) +
  ggtitle('Maksimalne plače v regijah') +
  ylab('Plača (€)')+
  theme(legend.title=element_text(size=8), legend.text=element_text(size=7), legend.key.size = unit(0.5, 'cm')) +
  scale_fill_discrete(name = "Panoga")

#katera panoga v regiji ima minimalno povprecno letno placo
min.place.v.regiji <- ggplot(place.min) + aes(x=STATISTICNA.REGIJA, y=MIN.LETNA.PLACA,fill=SKD.DEJAVNOST) + geom_col() +
  xlab("Regija") + theme(axis.text.x = element_text(size = 6, angle = 90, vjust = 0.5, hjust=1)) +
  ggtitle('Minimalne plače v regijah') +
  ylab('Plača (€)')+
  theme(legend.title=element_text(size=8), legend.text=element_text(size=7), legend.key.size = unit(0.5, 'cm'))+
  scale_fill_discrete(name = "Panoga")

#vsota povprečnih plač regij za vsako dejavnost - koliko vsaka regija 'prispeva' k neki dejavnosti
g3 <- ggplot(letne.place) + aes(x=substr(SKD.DEJAVNOST, 1,1) , y=POVPRECNA.LETNA.PLACA, fill=STATISTICNA.REGIJA) +
  geom_col(col = 'black') +
  xlab("Dejavnost") +
  ylab('Plače (€)') +
  scale_fill_discrete(name = "Regija") +
  ggtitle('Vsota plač po regijah za posamezno dejavnost')

#višina plač v regijah za vsako panogo - koliko je vsaka od panog razvita v posamezni regiji - v shiny-ju
g41 <- ggplot(letne.place1) + aes(x=STATISTICNA.REGIJA, y=POVPRECNA.LETNA.PLACA, fill=SKD.DEJAVNOST) +
  geom_col(position="dodge",col = 'black')+
  theme(legend.title=element_text(size=8), legend.text=element_text(size=7), legend.key.size = unit(0.5, 'cm'))+
  xlab('Regija') + ylab('Plača') + scale_fill_discrete(name = "Panoga")

g42 <- ggplot(letne.place2) + aes(x=STATISTICNA.REGIJA, y=POVPRECNA.LETNA.PLACA, fill=SKD.DEJAVNOST) +
  geom_col(position="dodge",col = 'black') +
  theme(legend.title=element_text(size=8), legend.text=element_text(size=7), legend.key.size = unit(0.5, 'cm'))+
  xlab('Regija') + ylab('Plača')+ scale_fill_discrete(name = "Panoga")

#grafi po panogah - v shiny-ju
g5 <- ggplot(data=letne.place, aes(x=STATISTICNA.REGIJA, y=POVPRECNA.LETNA.PLACA, fill=STATISTICNA.REGIJA)) +
  geom_col() + facet_wrap(~ substr(SKD.DEJAVNOST, 1,1)) +
  coord_flip() + theme(axis.text.x = element_text(size = 6, angle = 90, vjust = 0.5, hjust=1), legend.position="none")

#grafi po regijah - v shiny-ju
g6 <- ggplot(data=letne.place, aes(x=substr(SKD.DEJAVNOST,1,1), y=POVPRECNA.LETNA.PLACA, fill=substr(SKD.DEJAVNOST, 1,1))) +
  geom_col() + facet_wrap(~ STATISTICNA.REGIJA) + theme(axis.text.x = element_text(size = 6, angle = 90, vjust = 0.5, hjust=1), legend.position="none") +
  xlab("PANOGA")


#研究t_for时间，即弯月面形成时间
#x轴是电压频率，y轴是t_for，legend是流量

#设定工作目录
setwd("D:/data")
library(xlsx)
 library(RColorBrewer)

#读取数据
k1<-read.xlsx("t_for_z.xls", sheetName = "0.2", header = TRUE)
k2<-read.xlsx("t_for_z.xls", sheetName = "0.3", header = TRUE)
k3<-read.xlsx("t_for_z.xls", sheetName = "0.4", header = TRUE)
k4<-read.xlsx("t_for_z.xls", sheetName = "0.5", header = TRUE)
#names(k1)<-c("q", 5, 10, 20, 30, 50, 75, 100, 125, 150, 175, 200, 250)
#seq(from=0， to=1, seq.out=12)
mycolors <-brewer.pal(12,"Paired")
par(mfrow=c(2,2), mar=c(4,4,2,2), oma=c(2,2,2,2))

plot(k1$q, k1[,1], xaxs = "r", col = 0, xlab = "Flow rate (nl/min)", ylab = "t_for (ms)", main = "K = 0.2", cex.lab = 1.2, cex.main = 1.3, xlim = c(0, 180), ylim = c(0.2, 36))
for (i in 1:12) {
lines(k1$q, k1[, i+1], col=mycolors[i], lwd=2, type="l", lty=1)
}

legend("topright", c("5Hz", "10Hz", "20Hz", "30Hz", "50Hz", "75Hz", "100Hz", "125Hz", "150Hz", "175Hz", "200Hz", "250Hz"), col = mycolors, lwd = 2, lty = 1, cex = 0.8, bty = "n", inset = .03)

plot(k2$q, k2[,1], xaxs = "r", col = 0, xlab = "Flow rate (nl/min)", ylab = "t_for (ms)", main = "K = 0.3", cex.lab = 1.2, cex.main = 1.3, xlim = c(0, 180), ylim = c(0.2, 30))
for (i in 1:12) {
lines(k2$q, k2[, i+1], col=mycolors[i], lwd=2, type="l", lty=1)
}

plot(k3$q, k3[,1], xaxs = "r", col = 0, xlab = "Flow rate (nl/min)", ylab = "t_for (ms)", main = "K = 0.4", cex.lab = 1.2, cex.main = 1.3, xlim = c(0, 180), ylim = c(0.2, 25))
for (i in 1:12) {
lines(k3$q, k3[, i+1], col=mycolors[i], lwd=2, type="l", lty=1)
}

plot(k4$q, k4[,1], xaxs = "r", col = 0, xlab = "Flow rate (nl/min)", ylab = "t_for (ms)", main = "K = 0.5", cex.lab = 1.2, cex.main = 1.3, xlim = c(0, 180), ylim = c(0.2, 50))
for (i in 1:12) {
lines(k4$q, k4[, i+1], col=mycolors[i], lwd=2, type="l", lty=1)
}


# First R script

# take first number from user
x <- readline(prompt='Enter first number:')

# convert character to numeric
a <- as.double(x)

# take second number from user
y <- readline(prompt='Enter first number:')

# convert character to numeric
b <- as.double(y)

# Store their addition in another v
ariable
addition <- a + b

# Store their subtraction in another variable
subtraction <- a - b

# Store their division in another variable
division <- a / b

# Store their multiplication in another variable
multiplication <- a * b

# print results
print(addition)
print(subtraction)
print(division)
print(multiplication)


library(plyr)
library(ggplot2)
library(scales)
library(grid)

all_data <- data.frame(V1=integer(), V2=integer(),
                       V3=integer(), V4=integer(),
                       V5=integer(), V6=integer(),
                       middlebox=character())

vignat <- read.table("vignat-latency-breakpoint.txt")
vignat["middlebox"] <- "vignat"
unverified <- read.table("unverified-latency-breakpoint.txt")
unverified["middlebox"] <- "unverified"

all_data <- rbind(all_data, vignat)
all_data <- rbind(all_data, unverified)

cbbPalette <- c("#000000", "#E69F00", "#56B4E9", "#009E73", "#F0E442", "#0072B2", "#D55E00", "#CC79A7")

pd <- position_dodge(1)

p1 <- ggplot(all_data, aes(x=V3/1e6, y=V5/1e3,
                          group=middlebox,
                          color=middlebox,
                          shape=middlebox)) +
     geom_point(size=3) +
     geom_line() +
     geom_errorbar(aes(ymin=(V5-V6)/1e3, ymax=(V5+V6)/1e3), width=.01) +
     labs(title="1 way latency, single flow") +
     xlab("rate (Mpkt/s)") +
     ylab(bquote("1-way latency, microsec, log scale")) +
     theme_bw() +
     scale_y_log10(breaks = trans_breaks("log10", function(x) 10^x),
                   labels = trans_format("log10", math_format(10^.x))) +
     #expand_limits(x=0,y=0) +
     theme( plot.margin = unit( c(0,0,0,0) , "in" ) )

p2 <- ggplot(all_data, aes(x=V3/1e6, y=V4,
                          group=middlebox,
                          color=middlebox,
                          shape=middlebox)) +
     geom_point(size=3) +
     geom_line() +
     xlab("rate (Mpkt/s)") +
     ylab(bquote("packet loss, fraction, log scale")) +
     scale_y_log10(breaks = trans_breaks("log10", function(x) 10^x),
                   labels = trans_format("log10", math_format(10^.x))) +
     theme_bw() +
     #expand_limits(x=0,y=0) +
     theme( plot.margin = unit( c(0,0,0,0) , "in" ) )

png("lll.png",width=1700,height=1200,res=140)
grid.newpage()
grid.draw(rbind(ggplotGrob(p1), ggplotGrob(p2), size="last"))
dev.off()

#ggsave(filename="lll.png", plot=p)
#ggsave(filename="lll.png")
#print(p)


#==============================================================================
# Hàm lọc các mô hình đa biến
# First date: 12/04/2019
# Hàm này dùng để lọc mô hình đa biến cuối cùng
# Đầu vào là file data đã được tính woe
# Đầu ra là coef, pvalue, auc, ks, vif, trọng số
#=============================================================================

#=============================================================================
mfa_metrics <- function(fit) {
  # library(ROCR)
  # library(magrittr)
  # KS
  logit_scores <- prediction(fit$fitted.values, fit$y)
  logit_perf <- performance(logit_scores, "tpr", "fpr")
  logit_ks <-
    max(logit_perf@y.values[[1]] - logit_perf@x.values[[1]]) %>% set_names("ks")
  # AUC
  logit_perf_auc <- performance(logit_scores, "auc")
  logit_auc <- logit_perf_auc@y.values[[1]] %>% set_names("auc")
  # Acurracy
  pred <-
    ifelse(fit$fitted.values > 0.5, "1", "0") %>% factor(., levels = c("0", "1"), labels = c("0", "1"))
  truth <-
    fit$y %>% factor(., levels = c("0", "1"), labels = c("0", "1"))
  conf <- caret::confusionMatrix(pred, truth, mode = "everything")
  # Output
  metric <- c(logit_auc, logit_ks, conf$overall, conf$byClass) %>%
    t() %>%
    as.data.frame()

  return(metric)
}

#=============================================================================
# Các thước đo về mô hình
mfa_turn_cutoffs <- function(fit){
  #library(ROCR)
  logit_scores <- prediction(fit$fitted.values, fit$y)
  logit_perf_roc <- performance(logit_scores, "tpr", "fpr")
  logit_perf_prec_rec <- performance(logit_scores, "prec", "rec")
  logit_perf_sens_spec <- performance(logit_scores, "sens", "spec")
  logit_perf_lift <- performance(logit_scores, "lift", "rpp")

  logit_measure <- c("acc", "err", "fpr", "tpr", "fnr", "tnr",
                     "ppv", "npv", "phi", "lift", "f", "rch",
                     "auc", "prbe", "cal", "rmse")

  # ppv Positive predictive value = Precision
  # tpr True positive rate = Recall
  # mat Matthews correlation coefficient
  perf_all <- purrr::map(logit_measure, function(x) {
    pref <- performance(logit_scores, x)
    value <- pref@y.values %>% unlist() %>%  as.numeric()
  })

  names(perf_all) <- logit_measure
  list(
    logit_perf_roc = logit_perf_roc,
    logit_perf_prec_rec = logit_perf_prec_rec,
    logit_perf_sens_spec = logit_perf_sens_spec,
    logit_perf_lift = logit_perf_lift,
    perf_all = perf_all
  ) %>% return()

}

#=============================================================================
# Hàm chuẩn hóa hệ số beta
# mfa_sd_beta <- function(fit){
#   b <- summary(fit)$coef[-1, 1]
#   sx <- sapply(fit$model[-1], sd)
#   sy <- sd(fit$y)
#   beta <- b * sx/sy
#   return(beta)
# }

#=============================================================================
# Hàm tính toán các đầu ra liên quan đến hệ số beta
mfa_estimate <- function(fit){
  # VIF
  mvif <- car::vif(fit) %>%
    as.data.frame() %>%
    rownames_to_column() %>%
    set_colnames(c("term","vif"))
  # Coef
  standard_estimate <- mfa_sd_beta(fit) %>%
    as.data.frame() %>%
    rownames_to_column()%>%
    set_colnames(c("term","standard_estimate"))

  coef_summary <- fit %>%
    broom::tidy() %>%
    left_join(standard_estimate, by = "term") %>%
    left_join(mvif, by = "term") %>%
    mutate(weight_estimate = abs(standard_estimate)/ sum(abs(standard_estimate), na.rm = TRUE))

  coef_summary %>% return()

}

#=============================================================================
mfa_combn_predictors <-
  function(predictors,
           y = "good_bad",
           min = NULL,
           max = NULL) {
    # Dạng mô  hình
    f_model_form <-
      function(x) {
        paste(y, paste(x, collapse = '+'), sep = "~")
      }
    # Kết hợp biến
    f_combn <- function(i) {
      combn(predictors, i, f_model_form)
    }
    # Tất cả các kết hợp
    formulas <- map(min:max, f_combn) %>%
      unlist()
    # Output
    return(formulas)
  }

#=============================================================================
# f_perf <- function(fit) {
#   logit_performance <-
#     list(fitted.values = fit$fitted.values, y = fit$y)
#   return(logit_performance)
# }

# ============================================================================
# This function is using to check require conditions of model like
# pvalue, beta, vif, weight
# Inputs are tidy estimate

f_check_est <- function(estimate,
                        limit_pvalue = 0.05,
                        limit_vif = 10,
                        beta_weight_min = 0.05,
                        beta_weight_max = 0.3) {

  est <- estimate[-1,]

  check_est <- data.frame(
    check_beta = if_else(any(est$estimate > 0), "any beta > 0", "pass"),
    check_pvalue = if_else(
      any(est$p.value > limit_pvalue),
      paste("any pvalue >", limit_pvalue),
      "pass"
    ),
    check_vif = if_else(any(est$vif > limit_vif), paste("any vif >", limit_vif), "pass"),
    check_weight = case_when(
      any(est$weight_estimate > beta_weight_max) ~ paste0("any weight > ", beta_weight_max * 100, "%"),
      any(est$weight_estimate < beta_weight_min) ~ paste0("any weight < ", beta_weight_min * 100, "%"),
      TRUE ~ "pass"
    ),
    stringsAsFactors = FALSE

  )
  return(check_est)
}

#=============================================================================
filter_mfa <-
  function(df,
           y = "good_bad",
           nbr_predictors_min = 5,
           nbr_predictors_max = 12,
           limit_pvalue = 0.05,
           limit_vif = 10,
           beta_weight_min = 0.05,
           beta_weight_max = 0.3,
           limit_auc = 0.65,
           limit_ks = 0.6,
           var_skip = NULL
  ) {
    # Danh sách biến
    predictors <- df %>% names() %>% setdiff(c(y, var_skip))
    # Check: nbr_predictors_max vs nbr of predictors
    nbr_predictors_max <- min_na_rm(length(predictors), nbr_predictors_max)
    # Kết hợp biến
    combine_predictor <-
      mfa_combn_predictors(predictors, y, nbr_predictors_min, nbr_predictors_max)
    # regression

    f_fit <- partial(glm, family = binomial(link = "logit"), data = df)
    f_mfa_metrics <- compose(mfa_metrics, f_fit, as.formula)
    f_mfa_estimate <- compose(mfa_estimate, f_fit, as.formula)

    fit_all_model <- tibble(formula_name = combine_predictor) %>%
      mutate(
        #formulas = map(formula_name, as.formula),
        #fit = map(formulas, f_fit),
        metrics = map(formula_name, f_mfa_metrics),
        estimate = map(formula_name, f_mfa_estimate),
        check = map(estimate, f_check_est)
      ) %>%
      mutate(model_name = paste0("mod_", row_number())) %>%
      select(model_name, everything()) %>%
      unnest(metrics) %>%
      unnest(check) %>%
      mutate(check_auc = case_when(auc < limit_auc ~ paste("auc <", limit_auc), TRUE ~ "pass")) %>%
      mutate(check_ks = case_when(ks < limit_ks ~ paste("ks <", limit_ks), TRUE ~ "pass")) %>%
      mutate(
        check_all = case_when(
          check_beta == "pass" & check_pvalue == "pass" &
            check_vif == "pass" &
            check_weight == "pass" &
            check_auc == "pass" &
            check_ks == "pass" ~ "pass",
          TRUE ~ "not pass"
        )
      )

    # Tue Jun 25 14:59:14 2019 ------------------------------
    tbl_models <-
      fit_all_model %>%
      select(
        model_name,
        formula_name,
        auc,
        ks,
        Accuracy,
        Kappa,
        Sensitivity,
        Specificity,
        F1,
        check_beta,
        check_pvalue,
        check_vif,
        check_weight,
        check_auc,
        check_ks,
        check_all
      )
    # Tue Jun 25 14:59:29 2019 ------------------------------
    tbl_estimate <- fit_all_model %>%
      select(model_name,
             formula_name,
             estimate) %>%
      unnest(estimate)

    return(list(tbl_models = tbl_models, tbl_estimate = tbl_estimate))

  }

#=============================================================================
filter_mfa_stepwise <- function(df,
                            y = "good_bad",
                            nbr_predictors_min = 5,
                            nbr_predictors_max = 12,
                            limit_pvalue = 0.05,
                            limit_vif = 10,
                            beta_weight_min = 0.05,
                            beta_weight_max = 0.3,
                            limit_auc = 0.65,
                            limit_ks = 0.6,
                            var_skip = NULL) {

  # Danh sách biến
  predictors <- df %>% names() %>% setdiff(c(y, var_skip))
  df2 <- df %>% select(c(y, predictors))
  # stepwise

  m1 <- glm(good_bad ~ ., family = binomial(), data = df2)

  m_step <- step(m1, direction="both", trace=FALSE)
  m2 <- eval(m_step$call)

}

#=============================================================================


add_DayNumber <- function(ds) {
  	dates <- as.Date(ds)
	return (as.integer(format(dates,"%d")))
}

add_MonthNumber <- function(ds) {
  	dates <- as.Date(ds)
	return (as.integer(format(dates,"%m")))
}


\name{graph_from_file}
\alias{graph_from_file}
%- Also NEED an '\alias' for EACH other topic documented here.
\title{
  Read file to a PAFit_net object
}
\description{
  This function reads an input file to a \code{PAFit_net} object. Accepted formats are the edgelist format or the \code{gml} format.
}
\usage{
 graph_from_file(file_name, format = "edgelist", type = "directed")
}
%- maybe also 'usage' for other objects documented here.
\arguments{
  \item{file_name}{
    A string indicates the file name.
  }
  \item{format}{
    String. Possible values are \code{"edgelist"} and \code{"gml"}.

If \code{format} is \code{"edgelist"}, we assume the following edgelist matrix format. Each row is assumed to be of the form (\code{from_node_id} \code{to_node_id} \code{time_stamp}).
\code{from_node_id} is the id of the source node. \code{to_node_id} is the id of the destination node. \code{time_stamp} is the arrival time of the edge. \code{from_node_id} and \code{to_node_id} are assumed to be integers that are at least \eqn{0}. They need not to be contiguous.

To register a new node \eqn{i} at time \eqn{t} without any edge, add a row with format (\code{i -1 t}). This works for both undirected and directed networks.

\code{time_stamp} can be either numeric or string. The value of a time-stamp can be arbitrary, but we assume that a smaller time_stamp (regarded so by the \code{sort} function in \code{R}) represents an earlier arrival time. Examples of time-stamps that satisfy this assumption are the integer \code{0:T}, the string format `yyyy-mm-dd', and the POSIX time.

  If \code{format} is \code{"gml"}, there must be a binary field \code{directed} indicating the type of the network (\code{0}: undirected, \code{1}: directed). The required fields for an edge are: \code{source}, \code{target}, and \code{time}. \code{source} and \code{target} are the ID of the source node and the target node, respectively. \code{time} is the time-stamp of the edge. The required fields for a node are: \code{id}, \code{isolated} (binary) and \code{time}. The binary field \code{isolated} indicates whether this node is an isolated node when it enters the system or not. If \code{isolated} is \code{1}, then \code{time} must contain the node's appearance time. If \code{isolated} is \code{0}, then we can automatically infer the node's appearance time from its edges, so the field \code{time} in this case can be \code{NULL}. The assumptions on node IDs and the format of time-stamps are the same as in the case when \code{format = "edgelist"}. See \code{\link{graph_to_file}} to see detail on the format of the \code{gml} file this package outputs.
}
\item{type}{
   String. Indicates whether the network is \code{"directed"} or \code{"undirected"}. This option is ignored if \code{format} is \code{"gml"}, since the information is assumed to be contained in the \code{gml} file.
  }
}

\value{
  An object of class \code{PAFit_net} containing the network.
}
\author{
  Thong Pham \email{thongpham@thongpham.net}
}

\examples{
  library("PAFit")
  # a network from Bianconi-Barabasi model
  net        <- generate_BB(N = 50 , m = 10 , s = 10)

  #graph_to_file(net, file_name = "test.gml", format = "gml")
  #reread    <- graph_from_file(file_name = "test.gml", format = "gml")
}


#' vpaTorr
#'
#' Calculate water vapor pressure in torr.
#'
#' @param t numeric Air temperature in degC.
#' @return vpa in Torr
#'
#'
#' @author Istituto per la Bioeconomia CNR Firenze Italy  Alfonso Crisci \email{alfonso.crisci@@ibe.cnr.it}
#' @keywords  vpaTorr
#'
#' @export
#'
#'
#'
#'

vpaTorr=function(t) {
                         ct$assign("T", as.array(t))
                         ct$eval("var res=[]; for(var i=0, len=T.length; i < len; i++){ res[i]=vpaTorr(T[i])};")
                         res=ct$get("res")
                         return(ifelse(res==9999,NA,res))
}


[[[[[
   Given an expr to enumerate (program output) pairs,
   we simulate the Turing machine defined this way.
   We assume this r.e. set of programs is prefix free,
   i.e., no extension of a valid program is a valid
   program.  If so, we will carry out this simulation
   in a self-delimiting way, i.e., we won't read any
   unnecessary bits of the program.
]]]]]

define pi

[this is the prefix to put in front of the expr to
enumerate the infinite set of (program output) pairs]

    [graph is an unending expression for (p o) pairs]
    let graph read-exp

    [program read so far; initialize to empty bit string]
    let p nil

    let (look-for p [in] pairs)
       if atom pairs false
       [(add new macro caar -> car car to interpreter?)]
       if = p car car pairs [does first pair start with p?]
          car pairs   [if so, return first pair]
          [otherwise, keep looking]
          (look-for p [in] cdr pairs)

    let (look-for-extension-of p [in] pairs)
       if atom pairs false
       if (is-prefix? p car car pairs)
          true
          (look-for-extension-of p [in] cdr pairs)

    let (is-prefix? p q) [is p a prefix of q?]
       if atom p true
       if atom q false
       if = car p car q
          (is-prefix? cdr p cdr q)
          false

    let (loop t)
       [run for time t expr to generate (program output) pairs]
       [pairs are displayed by graph]
       let pairs debug caddr try debug t graph nil
       let found-it? (look-for p pairs) [found pair with program p?]
       if found-it? cadr found-it? [if so, we have output for p!]
       [(if found-it? isn't false, then it's considered true)]
       [is an extension of p in there?]
       if (look-for-extension-of p [in] pairs)
                  [if so, read another bit of p]
           [then] let p debug append p cons read-bit nil
                     (loop + t 1) [and generate more pairs]
                  [don't read more of p, just generate more pairs]
           [else] (loop + t 1)

    [initialize time t to 0]
    (loop 0)

define      pi
value       ((' (lambda (graph) ((' (lambda (p) ((' (lambda (l
            ook-for) ((' (lambda (look-for-extension-of) ((' (
            lambda (is-prefix?) ((' (lambda (loop) (loop 0)))
            (' (lambda (t) ((' (lambda (pairs) ((' (lambda (fo
            und-it?) (if found-it? (car (cdr found-it?)) (if (
            look-for-extension-of p pairs) ((' (lambda (p) (lo
            op (+ t 1)))) (debug (append p (cons (read-bit) ni
            l)))) (loop (+ t 1)))))) (look-for p pairs)))) (de
            bug (car (cdr (cdr (try (debug t) graph nil)))))))
            )))) (' (lambda (p q) (if (atom p) true (if (atom
            q) false (if (= (car p) (car q)) (is-prefix? (cdr
            p) (cdr q)) false)))))))) (' (lambda (p pairs) (if
             (atom pairs) false (if (is-prefix? p (car (car pa
            irs))) true (look-for-extension-of p (cdr pairs)))
            )))))) (' (lambda (p pairs) (if (atom pairs) false
             (if (= p (car (car pairs))) (car pairs) (look-for
             p (cdr pairs))))))))) nil))) (read-exp))

[graph = (1 0) (01 1) (001 2) (0001 3) (00001 4) etc.]
define graph
    let (loop p n)
  [do!] cons display cons p cons n nil
             (loop  cons 0 p  + 1 n)
    (loop '(1) 0)

define      graph
value       ((' (lambda (loop) (loop (' (1)) 0))) (' (lambda (
            p n) (cons (display (cons p (cons n nil))) (loop (
            cons 0 p) (+ 1 n))))))

[test it!]

try 10 graph nil

expression  (try 10 graph nil)
value       (failure out-of-time (((1) 0) ((0 1) 1) ((0 0 1) 2
            ) ((0 0 0 1) 3) ((0 0 0 0 1) 4) ((0 0 0 0 0 1) 5)
            ((0 0 0 0 0 0 1) 6) ((0 0 0 0 0 0 0 1) 7) ((0 0 0
            0 0 0 0 0 1) 8)))

run-utm-on

append

     bits pi

append

     bits graph

     '(0 0 0 1)

expression  (car (cdr (try no-time-limit (' (eval (read-exp)))
             (append (bits pi) (append (bits graph) (' (0 0 0
            1)))))))
debug       0
debug       ()
debug       1
debug       ()
debug       2
debug       (((1) 0))
debug       (0)
debug       3
debug       (((1) 0) ((0 1) 1))
debug       (0 0)
debug       4
debug       (((1) 0) ((0 1) 1) ((0 0 1) 2))
debug       (0 0 0)
debug       5
debug       (((1) 0) ((0 1) 1) ((0 0 1) 2) ((0 0 0 1) 3))
debug       (0 0 0 1)
debug       6
debug       (((1) 0) ((0 1) 1) ((0 0 1) 2) ((0 0 0 1) 3) ((0 0
             0 0 1) 4))
value       3


#' Unit Testing script for NMF package: NMF utility functions.
#'
#' @author Renaud Gaujoux
#' @creation 10 Aug 2010

#' Unit test for rmatrix: random matrix generation
test.rmatrix <- function(){

	n <- 100; p <- 20
	A <- matrix(1, n, p)

	# square matrix if y is missing
	set.seed(123456); M <- matrix(runif(n*n), n, n)
	set.seed(123456); checkIdentical(M, rmatrix(n), "Square matrix if 'y' is missing")
	set.seed(123456); checkIdentical(M, rmatrix(matrix(NA, nrow(M), ncol(M))), "Correct if 'x' is a matrix")

	# from NMF model
	model <- rnmf(3, A)
	set.seed(123456); M <- fitted(model) + matrix(runif(n*p), n, p)
	set.seed(123456); checkIdentical(M, rmatrix(model), "Correct if 'x' is an NMF model")
	set.seed(123456); M <- fitted(model) + matrix(rnorm(n*p), n, p)
	set.seed(123456); checkIdentical(M, rmatrix(model, dist=rnorm), "dist is passed correctly if 'x' is an NMF model")

	# default dist is uniform
	set.seed(123456); M <- matrix(runif(n*p), n, p)
	set.seed(123456); checkIdentical(M, rmatrix(n, p), "Default correctly to 'runif'")
	set.seed(123456); checkIdentical(M, rmatrix(A), "Default correctly to 'runif' (arg: matrix)")

	# argument byrow is correctly passed
	set.seed(123456); M <- matrix(runif(n*p), n, p, byrow=TRUE)
	set.seed(123456); checkIdentical(M, rmatrix(n, p, byrow=TRUE), "argument byrow is correctly passed")
	set.seed(123456); checkIdentical(M, rmatrix(A, byrow=TRUE), "argument byrow is correctly passed (arg: matrix)")

	# argument dimnames is correctly passed
	dims <-list(rep('a',n), rep('b',p))
	set.seed(123456); M <- matrix(runif(n*p), n, p, dimnames=dims)
	set.seed(123456); checkIdentical(M, rmatrix(n, p, dimnames=dims), "argument dimnames is correctly passed")
	set.seed(123456); checkIdentical(M, rmatrix(A, dimnames=dims), "argument dimnames is correctly passed (arg: matrix)")

	# can pass distribution function
	set.seed(123456); M <- matrix(rnorm(n*p), n, p)
	set.seed(123456); checkIdentical(M, rmatrix(n, p, dist=rnorm), "argument dist is correctly passed")
	set.seed(123456); checkIdentical(M, rmatrix(A, dist=rnorm), "argument dist is correctly passed (arg: matrix)")

	# can pass distribution functions as third argument
	set.seed(123456); M <- matrix(rnorm(n*p), n, p)
	set.seed(123456); checkIdentical(M, rmatrix(n, p, rnorm), "argument dist is the third argument")
	set.seed(123456); checkIdentical(M, rmatrix(A, rnorm), "argument dist is the second argument (arg: matrix)")

	# can pass extra arguments to distribution function
	set.seed(123456); M <- matrix(rnorm(n*p, 20), n, p)
	set.seed(123456); checkIdentical(M, rmatrix(n, p, rnorm, mean=20), "extra arguments are passed to the distribution function")
	set.seed(123456); checkIdentical(M, rmatrix(A, rnorm, mean=20), "extra arguments are passed to the distribution function (arg: matrix)")
}

#test.ptr_neq_constraints <- function(){
#
#	.do_constrain <- function(...){
#
#	}
#
#	.check <- function(c, msg){
#		.msg <- function(...) paste(msg, ':', ...)
#		x <- rmatrix(20,3)
#		y <- NMF:::neq.constraints.inplace(x, copy=TRUE)
#		checkIdentical(max.col(y[1:9,]), c(rep(1,3), rep(2,3), rep(3,3)), .msg("Max are ok"))
#		checkIdentical(y[-(1:9,], , .msg("Non constrained rows are identical"))
#	}
#
#	#.check(list(1:3,4:6,7:9), "")
#
#
#
#}

test.nmfWrapper <- function(){

	.msg <- NULL
	msg <- function(...) paste(.msg, ': ', ..., sep='')

	f <- nmfWrapper('lee')
	x <- rmatrix(20, 10)
	checkTrue( isNMFfit(res <- f(x, 3)), msg('result is an NMFfit object') )
	checkIdentical(nbasis(res), 3L, msg('result was computed using the correct rank') )
	checkIdentical(algorithm(res), 'lee', msg('result was computed using the correct algorithm') )

	.msg <- 'with default maxIter and seed value'
	f <- nmfWrapper('nsNMF', maxIter=3, seed='nndsvd')
	checkTrue( isNMFfit(res <- f(x, 2)), msg('result is an NMFfit object' ))
	checkIdentical(nbasis(res), 2L, msg('result was computed using the correct rank') )
	checkIdentical(algorithm(res), 'nsNMF', msg('result was computed using the correct algorithm') )
	checkIdentical(niter(res), 3L, msg('result was computed using the correct number of iterations') )
	checkIdentical(seeding(res), 'nndsvd', msg('result was computed using the correct seed') )
	# overwrite default in call
	.msg <- 'overwriting defaults in call'
	checkTrue( isNMFfit(res <- f(x, 4, seed='random')), msg('result is an NMFfit object' ))
	checkIdentical(nbasis(res), 4L, msg('result was computed using the correct rank') )
	checkIdentical(algorithm(res), 'nsNMF', msg('result was computed using the correct algorithm') )
	checkIdentical(niter(res), 3L, msg('result was computed using the correct number of iterations') )
	checkIdentical(seeding(res), 'random', msg('result was computed using the correct seed') )
	# pass method as well
	.msg <- 'overwriting defaults in call + try overwrite method'
	checkWarning(res <- f(x, 4, method='lee', seed='random'), 'Discarding fixed arguments.*', msg('a warning is thrown'))
	checkTrue( isNMFfit(res), msg('result is an NMFfit object' ))
	checkIdentical(algorithm(res), 'nsNMF', msg('result was still computed using the correct algorithm defined in nmfWrapper') )

}


# This code creates the seroprevalence tables and
# figures for COVID-19 pandemic in Saint Petersburg, Russia
# paper
library(data.table)
library(stringi)
library(stringr)
library(lubridate)
library(ggplot2)
library(ggthemes)

# Declare working directory beforehand in an environment variable
# SPB_COVID_STUDY_PATH = "path_to_your_folder"
# with the aid of usethis::edit_r_environ()
# Restart R session for the changes to make effect
setwd(Sys.getenv('SPB_COVID_STUDY_PATH'))

#######
# Load and prepare the estimated prevalence across waves
# (see the estimation code in analysis/wave*/estimate_prevalence_by_{model,variable}.r)

waves <- c(1, 1.5, 2, 3)

# Init an object to store the results
# of prevalence computations
perwave_prevalence_by_model_list <- list()
perwave_prevalence_by_variable_level_list <- list()

# Load the per-wave estimates and store them in one object
for(w in waves) {

	load(paste0("estimates/wave", w, "/prevalence_by_model.rdata"))
	load(paste0("estimates/wave", w, "/prevalence_by_variable_level.rdata"))

	perwave_prevalence_by_model_list[[ as.character(w) ]] <- prevalence_by_model
	perwave_prevalence_by_variable_level_list[[ as.character(w) ]] <- prevalence_by_variable_level

	rm(prevalence_by_model)
	rm(prevalence_by_variable_level)

}

# Aggregate the results
perwave_prevalence_by_model <- rbindlist(perwave_prevalence_by_model_list, idcol = "wave")
perwave_prevalence_by_variable_level <- rbindlist(perwave_prevalence_by_variable_level_list, idcol = "wave")

# Define a variable for test adjustment
perwave_prevalence_by_model[ sensitivity == 1 & specificity == 1, test_adjustment := "unadjusted" ]
perwave_prevalence_by_model[ sensitivity != 1 & specificity == 1, test_adjustment := "adjusted" ]

perwave_prevalence_by_variable_level[ sensitivity == 1 & specificity == 1, test_adjustment := "unadjusted" ]
perwave_prevalence_by_variable_level[ sensitivity != 1 & specificity == 1, test_adjustment := "adjusted" ]

##############
# Table tab:seroprevalence_table

seroprevalence_table_data <- perwave_prevalence_by_model[ scenario == "basic" & serotest == "IgA_or_G_or_M_testC" & prevalence_type %in% c("naive", "univariate") & test_adjustment %in% c("adjusted", "unadjusted") & surveyweight == "no" ]

## Column 1
seroprevalence_table_data[ prevalence_type == "naive" & test_adjustment == "unadjusted", c("wave", "pointest", "lowerbound", "upperbound", "n_selection", "n_outcome")]

## Column 2
seroprevalence_table_data[ prevalence_type == "univariate" & test_adjustment == "unadjusted", c("wave", "pointest", "lowerbound", "upperbound", "n_selection", "n_outcome")]

## Column 3
seroprevalence_table_data[ prevalence_type == "univariate" & test_adjustment == "adjusted", c("wave", "pointest", "lowerbound", "upperbound", "n_selection", "n_outcome")]

##############
# Table tab:seroprevalence_table_robustness

seroprevalence_table_robustness_data <- perwave_prevalence_by_model[ scenario == "basic" & serotest %in% c("IgG_testB", "IgA_or_G_or_M_testC", "IgG_or_M_testD") & prevalence_type %in% c("naive", "univariate") & test_adjustment %in% c("adjusted", "unadjusted") & surveyweight %in% c("no", "raking") ]

seroprevalence_table_robustness_pointest <- dcast(seroprevalence_table_robustness_data[ test_adjustment == "adjusted"], wave ~ serotest + prevalence_type + surveyweight, value.var = c("pointest"))
seroprevalence_table_robustness_lowerbound <- dcast(seroprevalence_table_robustness_data[ test_adjustment == "adjusted"], wave ~ serotest + prevalence_type + surveyweight, value.var = c("lowerbound"))
seroprevalence_table_robustness_upperbound <- dcast(seroprevalence_table_robustness_data[ test_adjustment == "adjusted"], wave ~ serotest + prevalence_type + surveyweight, value.var = c("upperbound"))

##############
# Table tab:seroprevalence_by_subgroup

seroprevalence_by_subgroup_data <- perwave_prevalence_by_variable_level[ serotest %in% c( "IgA_or_G_or_M_testC") & prevalence_type %in% c("naive", "univariate") & test_adjustment %in% c("adjusted") & surveyweight %in% c("no") & !(variable %in% c("district", "draw_week", "draw_biweek", "interview_week"))]
seroprevalence_by_subgroup_data[ lowerbound < 0, lowerbound := 0 ]
seroprevalence_by_subgroup_data[ upperbound < 0, upperbound := 0 ]
seroprevalence_by_subgroup_data[ pointest == 0, c("lowerbound", "upperbound", "pointest") := NA]
seroprevalence_by_subgroup_data[, display_seroprevalence := paste0(pointest, " (", lowerbound, "--", upperbound, ")")]
seroprevalence_by_subgroup_data[ is.na(pointest), display_seroprevalence := "---"]

# Convert to tables to display
seroprevalence_by_subgroup_table_naive <- dcast(seroprevalence_by_subgroup_data[ prevalence_type == "naive"], variable + variable_level ~ wave, value.var = c("n_outcome", "display_seroprevalence"))
seroprevalence_by_subgroup_table_univariate <- dcast(seroprevalence_by_subgroup_data[ prevalence_type == "univariate"], variable + variable_level ~ wave, value.var = c("n_outcome", "display_seroprevalence"))
setcolorder(seroprevalence_by_subgroup_table_naive, c("variable", "variable_level", "n_outcome_1", "display_seroprevalence_1", "n_outcome_1.5", "display_seroprevalence_1.5", "n_outcome_2", "display_seroprevalence_2", "n_outcome_3", "display_seroprevalence_3"))
setcolorder(seroprevalence_by_subgroup_table_univariate, c("variable", "variable_level", "n_outcome_1", "display_seroprevalence_1", "n_outcome_1.5", "display_seroprevalence_1.5", "n_outcome_2", "display_seroprevalence_2", "n_outcome_3", "display_seroprevalence_3"))
# NAs to em-dashes
seroprevalence_by_subgroup_table_naive <- seroprevalence_by_subgroup_table_naive[, lapply(.SD, function(x) { ifelse(is.na(x), "---", x) })]
seroprevalence_by_subgroup_table_univariate <- seroprevalence_by_subgroup_table_univariate[, lapply(.SD, function(x) { ifelse(is.na(x), "---", x) })]

# Write to csv tables for subsequent latex import
#fwrite(seroprevalence_by_subgroup_table_naive, file = "temp/seroprevalence_by_subgroup_table_naive.csv")
#fwrite(seroprevalence_by_subgroup_table_univariate, file = "temp/seroprevalence_by_subgroup_table_univariate.csv")

##############
# Figure fig:seroprevalence_time

# Define start and end dates for all charts
start_date <- ymd("2020-03-01")
end_date <- ymd("2021-05-31")
start_end_range <- c(start_date, end_date)

# Convert date range to week numbers
start_end_range_weeknumbers <- lapply(start_end_range, isoweek)
# Add 2020 weeks to 2021
start_end_range_weeknumbers[[2]] <- start_end_range_weeknumbers[[2]] + 53

# Data for the plot
## Naive prevalence by draw sample week
prevalence_by_draw_sample_week <- perwave_prevalence_by_variable_level[ serotest %in% c("IgG_testB", "IgA_or_G_or_M_testC", "IgG_or_M_testD") & prevalence_type == "naive" & variable == "draw_week" & test_adjustment == "adjusted" ]
setnames(prevalence_by_draw_sample_week, "variable_level", "week")

# Proper week names
prevalence_by_draw_sample_week[ week == "October 5-11", week := 41 ]
prevalence_by_draw_sample_week[ week == "October 12-18", week := 42]
prevalence_by_draw_sample_week[ week == "October 19-25", week := 43 ]
prevalence_by_draw_sample_week[ week == "October 26 - November 1", week := 44]
prevalence_by_draw_sample_week[ week == "November 2-8", week := 45]
prevalence_by_draw_sample_week[ week == "November 9-15", week := 46]
prevalence_by_draw_sample_week[ week == "November 16-22", week := 47]
prevalence_by_draw_sample_week[ week == "November 23-29", week := 48]
prevalence_by_draw_sample_week[ week == "November 30 - December 6", week := 49]

prevalence_by_draw_sample_week[ week == "February 8-14, 2021", week := 53 + 6 ]
prevalence_by_draw_sample_week[ week == "February 15-21, 2021", week := 53 + 7]
prevalence_by_draw_sample_week[ week == "February 22-28, 2021", week := 53 + 8 ]
prevalence_by_draw_sample_week[ week == "March 1-7, 2021", week := 53 + 9]
prevalence_by_draw_sample_week[ week == "March 8-14, 2021", week := 53 + 10]
prevalence_by_draw_sample_week[ week == "March 15-21, 2021", week := 53 + 11]
prevalence_by_draw_sample_week[ week == "March 22-28, 2021", week := 53 + 12]
prevalence_by_draw_sample_week[ week == "March 29 - April 4, 2021", week := 53 + 13]
prevalence_by_draw_sample_week[ week == "April 5-11, 2021", week := 53 + 14]

# Add data on overall prevalence per wave
prevalence_by_draw_sample_week[, week := as.numeric(week)]
prevalence_by_draw_sample_week[week >= 22 & week <= 26, wave := 1 ]
prevalence_by_draw_sample_week[week >= 29 & week <= 33, wave := 1.5 ]
prevalence_by_draw_sample_week[week >= 41 & week <= 49, wave := 2 ]
prevalence_by_draw_sample_week[week >= 59 & week <= 67, wave := 3 ]

## Add the all-wave adjusted prevalence estimates
prevalence_waves_long <- perwave_prevalence_by_model[ scenario == "basic" & prevalence_type == "univariate" & serotest %in% c("IgG_testB", "IgA_or_G_or_M_testC", "IgG_or_M_testD") & surveyweight == "no" & test_adjustment == "adjusted" ]

prevalence_waves <- dcast(prevalence_waves_long, serotest + wave ~ ., value.var = c("lowerbound", "pointest", "upperbound"))
setnames(prevalence_waves, c("lowerbound", "pointest", "upperbound"), paste0(c("lowerbound", "pointest", "upperbound"), "_univariate"))

# Add the all-wave data
prevalence_by_draw_sample_week <- merge(prevalence_by_draw_sample_week, prevalence_waves, by = c("serotest", "wave"), all.x = T)

# Rename the tests
prevalence_by_draw_sample_week[serotest == "IgA_or_G_or_M_testC", serotest := "ELISA Coronapass"]
prevalence_by_draw_sample_week[serotest == "IgG_testB", serotest := "CMIA Abbott"]
prevalence_by_draw_sample_week[serotest == "IgG_or_M_testD", serotest := "ELISA Vector"]

# Remove rare weeks
prevalence_by_draw_sample_week <- prevalence_by_draw_sample_week[ n_outcome > 30 ]

# Add intervals for weeks where there was no serosurvey
#empty_weeks <- data.table(expand.grid(serotest = unique(prevalence_by_draw_sample_week$serotest), week = min(prevalence_by_draw_sample_week$week):max(prevalence_by_draw_sample_week$week)))
empty_weeks <- data.table(expand.grid(serotest = unique(prevalence_by_draw_sample_week$serotest), week = start_end_range_weeknumbers[[1]]:start_end_range_weeknumbers[[2]]))

empty_weeks <- empty_weeks[ !(week %in% prevalence_by_draw_sample_week$week) ]

prevalence_by_draw_sample_week <- rbind(prevalence_by_draw_sample_week, empty_weeks, fill = T)
setorderv(prevalence_by_draw_sample_week, c("week", "serotest"))

# Week labels
prevalence_by_draw_sample_week[ week == 22, week_label := "May 25-31"]
prevalence_by_draw_sample_week[ week == 23, week_label := "Jun 1-7"]
prevalence_by_draw_sample_week[ week == 24, week_label := "Jun 8-14"]
prevalence_by_draw_sample_week[ week == 25, week_label := "Jun 15-21"]
prevalence_by_draw_sample_week[ week == 26, week_label := "Jun 22-28"]
prevalence_by_draw_sample_week[ week == 30, week_label := "Jul 20-26"]
prevalence_by_draw_sample_week[ week == 31, week_label := "Jul 27\nAug 2"]
prevalence_by_draw_sample_week[ week == 32, week_label := "Aug 3-9"]
prevalence_by_draw_sample_week[ week == 33, week_label := "Aug 10-16"]
prevalence_by_draw_sample_week[ week == 41, week_label := "Oct 5-11"]
prevalence_by_draw_sample_week[ week == 42, week_label := "Oct 12-18"]
prevalence_by_draw_sample_week[ week == 43, week_label := "Oct 19-25"]
prevalence_by_draw_sample_week[ week == 44, week_label := "Oct 26\nNov 1"]
prevalence_by_draw_sample_week[ week == 45, week_label := "Nov 2-8"]
prevalence_by_draw_sample_week[ week == 46, week_label := "Nov 9-15"]
prevalence_by_draw_sample_week[ week == 47, week_label := "Nov 16-22"]
prevalence_by_draw_sample_week[ week == 48, week_label := "Nov 23-29"]
prevalence_by_draw_sample_week[ week == 49, week_label := "Nov 30\nDec 6"]
prevalence_by_draw_sample_week[ week == 53 + 6, week_label := "Feb 8-14"]
prevalence_by_draw_sample_week[ week == 53 + 7, week_label := "Feb 15-21"]
prevalence_by_draw_sample_week[ week == 53 + 8, week_label := "Feb 22-28"]
prevalence_by_draw_sample_week[ week == 53 + 9, week_label := "Mar 1-7"]
prevalence_by_draw_sample_week[ week == 53 + 10, week_label := "Mar 8-14"]
prevalence_by_draw_sample_week[ week == 53 + 11, week_label := "Mar 15-21"]
prevalence_by_draw_sample_week[ week == 53 + 12, week_label := "Mar 22-28"]
prevalence_by_draw_sample_week[ week == 53 + 13, week_label := "Mar 29\nApr 4"]
prevalence_by_draw_sample_week[ week == 53 + 14, week_label := "Apr 5-11"]

# Empty weeks
prevalence_by_draw_sample_week[ is.na(week_label), week_label := ""]

# Fix lowerbounds
prevalence_by_draw_sample_week[ lowerbound < 0, lowerbound := 0 ]

## Plot by draw sample week with univariate results
prevalence_plot_data <- prevalence_by_draw_sample_week[ serotest %in% c("ELISA Coronapass", NA) ]
perweek_labels <- unique(prevalence_plot_data[, c("week", "week_label")])

naive_vs_univariate_prevalence_plot <- ggplot(prevalence_plot_data[ week > 21 & week < 67 ], aes(x = week, y = pointest, color = serotest)) +
											geom_point(size = 2, position = position_dodge(width=0.5)) +
											geom_pointrange(aes(ymin = lowerbound, ymax = upperbound), lwd = 0.3, position = position_dodge(width=0.5)) +
											# Adjusted prevalence for the entire wave
											geom_line(aes(y = pointest_univariate, group = serotest), linetype = "solid", lwd = 2) +
											geom_ribbon(aes(ymin = lowerbound_univariate, ymax = upperbound_univariate, group = serotest), alpha = .3, colour = NA, fill = "grey70") +
											geom_text(aes(label = paste0(pointest, "%")), hjust = 1.2, vjust = 0.2, size = 3, position = position_dodge(width=0.5)) +
											scale_y_continuous(name = "Seroprevalence, % (dots: naïve, solid line: adj. for non-response + 95% CI)", limits = c(0, max(prevalence_by_draw_sample_week$upperbound))) +
											scale_x_continuous(	name = "Week of blood sample draw",
																breaks = perweek_labels$week, labels = perweek_labels$week_label,
																expand = c(0.05, 0), guide = guide_axis(n.dodge = 4)) +
											labs(color = "test") +
											theme_minimal() +
											theme(panel.grid.minor = element_blank(), axis.text.y = element_text(size = 12), text = element_text(size = 12), legend.position = "none")

# Return the plot
#cairo_pdf("pandemic_course_paper/media/seroprevalence_time.pdf", height = 7, width = 12)
#naive_vs_univariate_prevalence_plot
#dev.off()


REBOL [
	System: "REBOL [R3] Language Interpreter and Run-time Environment"
	Title: "Datatype action definitions"
	Rights: {
		Copyright 2012 REBOL Technologies
		REBOL is a trademark of REBOL Technologies
	}
	License: {
		Licensed under the Apache License, Version 2.0.
		See: http://www.apache.org/licenses/LICENSE-2.0
	}
	Note: [
		"This list is order dependent!"
		"Used to generate C enums and tables"
		"Boot bind attributes are SET and not DEEP"
		"Todo: before beta release remove extra/unused refinements"
	]
]

;-- Binary Math & Logic

add: action [
	{Returns the addition of two values.}
	value1 [scalar! date!]
	value2
]

subtract: action [
	{Returns the second value subtracted from the first.}
	value1 [scalar! date!]
	value2 [scalar! date!]
]

multiply: action [
	{Returns the first value multiplied by the second.}
	value1 [scalar!]
	value2 [scalar!]
]

divide: action [
	{Returns the first value divided by the second.}
	value1 [scalar!]
	value2 [scalar!]
]

remainder: action [
	{Returns the remainder of first value divided by second.}
	value1 [scalar!]
	value2 [scalar!]
]

power: action [
	{Returns the first number raised to the second number.}
	number [number!]
	exponent [number!]
]

and~: action [
	{Returns the first value ANDed with the second.}
	value1 [logic! integer! char! tuple! binary! bitset! typeset! datatype!]
	value2 [logic! integer! char! tuple! binary! bitset! typeset! datatype!]
]

or~: action [
	{Returns the first value ORed with the second.}
	value1 [logic! integer! char! tuple! binary! bitset! typeset! datatype!]
	value2 [logic! integer! char! tuple! binary! bitset! typeset! datatype!]
]

xor~: action [
	{Returns the first value exclusive ORed with the second.}
	value1 [logic! integer! char! tuple! binary! bitset! typeset! datatype!]
	value2 [logic! integer! char! tuple! binary! bitset! typeset! datatype!]
]

;-- Unary

negate: action [
	{Changes the sign of a number.}
	number [number! pair! money! time! bitset!]
]

complement: action [
	{Returns the one's complement value.}
	value [logic! integer! tuple! binary! bitset! typeset! image!]
]

absolute: action [
	{Returns the absolute value.}
	value [number! pair! money! time!]
]

round: action [
	{Rounds a numeric value; halves round up (away from zero) by default.}
	value [number! pair! money! time!] "The value to round"
	/to "Return the nearest multiple of the scale parameter"
	scale [number! money! time!] "Must be a non-zero value"
	/even      "Halves round toward even results"
	/down      "Round toward zero, ignoring discarded digits. (truncate)"
	/half-down "Halves round toward zero"
	/floor     "Round in negative direction"
	/ceiling   "Round in positive direction"
	/half-ceiling "Halves round in positive direction"
]

random: action [
	{Returns a random value of the same datatype; or shuffles series.}
	value   {Maximum value of result (modified when series)}
	/seed   {Restart or randomize}
	/secure {Returns a cryptographically secure random number}
	/only   {Pick a random value from a series}
]

odd?: action [
	{Returns TRUE if the number is odd.}
	number [number! char! date! money! time! pair!]
]

even?: action [
	{Returns TRUE if the number is even.}
	number [number! char! date! money! time! pair!]
]

;-- Series Navigation

head: action [
	{Returns the series at its beginning.}
	series [series! gob! port!]
]

tail: action [
	{Returns the series just past its end.}
	series [series! gob! port!]
]

head?: action [
	{Returns TRUE if a series is at its beginning.}
	series [series! gob! port!]
]

tail?: action [
	{Returns TRUE if series is at or past its end; or empty for other types.}
	series [series! gob! port! bitset! map!]
]

past?: action [
	{Returns TRUE if series is past its end.}
	series [series! gob! port!]
]

next: action [
	{Returns the series at its next position.}
	series [series! gob! port!]
]

back: action [
	{Returns the series at its previous position.}
	series [series! gob! port!]
]

skip: action [
	{Returns the series forward or backward from the current position.}
	series [series! gob! port!]
	offset [number! logic! pair!]
]

at: action [
	{Returns the series at the specified index.}
	series [series! gob! port!]
	index [number! logic! pair!]
]

index?: action [
	{Returns the current position (index) of the series.}
	series [series! gob! port! none!]
	/xy {Returns index as an XY pair offset}
]

length?: action [
	{Returns the length (from the current position for series.)}
	series [series! port! map! tuple! bitset! object! gob! struct! any-word! none!]
]

;-- Series Extraction

pick: action [
	{Returns the value at the specified position.}
	aggregate [series! map! gob! pair! date! time! tuple! bitset! port!]
	index {Index offset, symbol, or other value to use as index}
]

;-- Series Search

find: action [
	{Searches for a value; for series returns where found, else none.}
	series [series! gob! port! bitset! typeset! object! none!]
	value [any-type!]
	/part {Limits the search to a given length or position}
	length [number! series! pair!]
	/only {Treats a series value as only a single value}
	/case {Characters are case-sensitive}
	/any  {Enables the * and ? wildcards}
	/with {Allows custom wildcards}
	wild [string!] "Specifies alternates for * and ?"
	/skip {Treat the series as records of fixed size}
	size [integer!]
	/last {Backwards from end of series}
	/reverse {Backwards from the current position}
	/tail {Returns the end of the series}
	/match {Performs comparison and returns the tail of the match}
]

select: action [
	{Searches for a value; returns the value that follows, else none.}
	series [series! port! map! object! none!]
	value [any-type!]
	/part {Limits the search to a given length or position}
	length [number! series! pair!]
	/only {Treats a series value as only a single value}
	/case {Characters are case-sensitive}
	/any  {Enables the * and ? wildcards}
	/with {Allows custom wildcards}
	wild [string!] "Specifies alternates for * and ?"
	/skip {Treat the series as records of fixed size}
	size [integer!]
	/last {Backwards from end of series}
	/reverse {Backwards from the current position}
]

;;;;!!! MATCH

reflect: action [
	{Returns specific details about a datatype.}
	value [any-type!]
	field [word!] "Such as: spec, body, words, values, title"
]

;-- Making, copying, modifying

make: action [
	{Constructs or allocates the specified datatype.}
	type [any-type!] {The datatype or an example value}
	spec [any-type!] {Attributes or size of the new value}
]

to: action [
	{Converts to a specified datatype.}
	type [any-type!] {The datatype or example value}
	spec [any-type!] {The attributes of the new value}
]

copy: action [
	{Copies a series, object, or other value.}
	value [series! port! map! object! bitset! any-function!] {At position}
	/part {Limits to a given length or position}
	length [number! series! pair!]
	/deep {Also copies series values within the block}
	/types {What datatypes to copy}
	kinds [typeset! datatype!]
]

take: action [
	{Removes and returns one or more elements.}
	series [series! port! gob! none!] {At position (modified)}
	/part {Specifies a length or end position}
	length [number! series! pair!]
	/deep {Also copies series values within the block}
	/last {Take it from the tail end}
]

insert: action [
	{Inserts element(s); for series, returns just past the insert.}
	series [series! port! map! gob! object! bitset! port!] {At position (modified)}
	value [any-type!] {The value to insert}
	/part {Limits to a given length or position}
	length [number! series! pair!]
	/only {Only insert a block as a single value (not the contents of the block)}
	/dup {Duplicates the insert a specified number of times}
	count [number! pair!]
]

append: action [
	{Inserts element(s) at tail; for series, returns head.}
	series [series! port! map! gob! object! bitset!] {Any position (modified)}
	value [any-type!] {The value to insert}
	/part {Limits to a given length or position}
	length [number! series! pair!]
	/only {Only insert a block as a single value (not the contents of the block)}
	/dup {Duplicates the insert a specified number of times}
	count [number! pair!]
]

remove: action [
	{Removes element(s); returns same position.}
	series [series! gob! port! bitset! none!] {At position (modified)}
	/part {Removes multiple elements or to a given position}
	length [number! series! pair! char!]
]

change: action [
	{Replaces element(s); returns just past the change.}
	series [series! gob! port!]{At position (modified)}
	value [any-type!] {The new value}
	/part {Limits the amount to change to a given length or position}
	length [number! series! pair!]
	/only {Only change a block as a single value (not the contents of the block)}
	/dup {Duplicates the change a specified number of times}
	count [number! pair!]
]

poke: action [
	{Replaces an element at a given position.}
	series [series! port! map! gob! bitset!] {(modified)}
	index {Index offset, symbol, or other value to use as index}
	value [any-type!] {The new value (returned)}
]

clear: action [
	{Removes elements from current position to tail; returns at new tail.}
	series [series! port! map! gob! bitset! none!] {At position (modified)}
]

trim: action [
	{Removes spaces from strings or nones from blocks or objects.}
	series [series! object! error! module!] {Series (modified) or object (made)}
	/head {Removes only from the head}
	/tail {Removes only from the tail}
	/auto {Auto indents lines relative to first line}
	/lines {Removes all line breaks and extra spaces}
	/all  {Removes all whitespace}
	/with str [char! string! binary! integer!] {Same as /all, but removes characters in 'str'}
]

swap: action [
	{Swaps elements between two series or the same series.}
	series1 [series! gob!] {At position (modified)}
	series2 [series! gob!] {At position (modified)}
]

reverse: action [
	{Reverses the order of elements; returns at same position.}
	series [series! gob! tuple! pair!] {At position (modified)}
	/part {Limits to a given length or position}
	length [number! series!]
]

sort: action [
	{Sorts a series; default sort order is ascending.}
	series [series!] {At position (modified)}
	/case {Case sensitive sort}
	/skip {Treat the series as records of fixed size}
	size [integer!] {Size of each record}
	/compare  {Comparator offset, block or function}
	comparator [integer! block! any-function!]
	/part {Sort only part of a series}
	length [number! series!] {Length of series to sort}
	/all {Compare all fields}
	/reverse {Reverse sort order}
]

;-- Port actions:

create: action [
	{Send port a create request.}
	port [port! file! url! block!]
]

delete: action [
	{Send port a delete request.}
	port [port! file! url! block!]
]

open: action [
	{Opens a port; makes a new port from a specification if necessary.}
	spec [port! file! url! block!]
	/new   {Create new file - if it exists, reset it (truncate)}
	/read  {Open for read access}
	/write {Open for write access}
	/seek  {Optimize for random access}
	/allow {Specifies protection attributes}
		access [block!]
]

close: action [
	{Closes a port.}
	port [port!]
]

read: action [
	{Read from a file, URL, or other port.}
	source [port! file! url! block!]
	/part {Partial read a given number of units (source relative)}
		length [number!]
	/seek {Read from a specific position (source relative)}
		index [number!]
	/string {Convert UTF and line terminators to standard text string}
	/lines {Convert to block of strings (implies /string)}
;	/as {Convert to string using a specified encoding}
;		encoding [none! number!] {UTF number (0 8 16 -16)}
]

write: action [
	{Writes to a file, URL, or port - auto-converts text strings.}
	destination [port! file! url! block!]
	data [binary! string! block!] {Data to write (non-binary converts to UTF-8)}
	/part {Partial write a given number of units}
		length [number!]
	/seek {Write at a specific position}
		index [number!]
	/append {Write data at end of file}
	/allow {Specifies protection attributes}
		access [block!]
	/lines {Write each value in a block as a separate line}
;	/as {Convert string to a specified encoding}
;		encoding [none! number!] {UTF number (0 8 16 -16)}
]

open?: action [
	{Returns TRUE if port is open.}
	port [port!]
]

query: action [
	{Returns information about a port, file, or URL.}
	target [port! file! url! block!]
	/mode "Get mode information"
	field [word! none!] "NONE will return valid modes for port type"
]

modify: action [
	{Change mode or control for port or file.}
	target [port! file!]
	field [word! none!]
	value
]

update: action [
	{Updates external and internal states (normally after read/write).}
	port [port!]
]

rename: action [
	{Rename a file.}
	from [port! file! url! block!]
	to [port! file! url! block!]
]


# (1) Do not invoke another tf$InteractiveSession() during session noted by Mar 25 2018
# (2) Transpose: x_image <- tf$transpose(x_image2, perm=as.integer(c(0, 2, 3, 1)) )
# (3) Dynamic learning rate is the key noted by Mar 30 2018
# (4) Drop-out is not helping (He et al. 2016)
# 	We create a placeholder for the probability that a neuron’s output is kept during dropout. This allows us to turn dropout on during training, and turn it off during testing.
# 	keep_prob <- tf$placeholder(tf$float32)
# 	h_fc1_drop <- tf$nn$dropout(h_fc1, keep_prob)
# (5) mini-batch can save memory & avoid local minimum, Bottou, L. (2010). Large-scale machine learning with stochastic gradient descent. In Proceedings of COMPSTAT'2010 (pp. 177-186). Physica-Verlag HD.
# (6) batch normalization is referring to https://r2rt.com/implementing-batch-normalization-in-tensorflow.html

# source("cnn.common.r");
source("build_graph.r");
source("confusion.r");

# input_dim_x=13; input_dim_y=3;
is_greater <- function(accuracies.validation, inner_i_validation, plat_n, type=1) {
	first_half  <- sort(accuracies.validation[(inner_i_validation-plat_n+1):(inner_i_validation-plat_n/2)], decreasing=FALSE);
	second_half <- sort(accuracies.validation[(inner_i_validation-plat_n/2+1):(inner_i_validation)], decreasing=TRUE);
	# top_n <- as.integer(plat_n/2*33/100);
	# top_n <- 1;
	top_n <- ceiling(plat_n/2/2);
	if (type==1) {
		resutls <- mean(first_half[1:(plat_n/2-top_n)]) > mean(second_half[1:(plat_n/2-top_n)]);
	} else {
		top_n <- 1;
		# resutls <- mean(first_half[1:(plat_n/2-top_n)]) > mean(second_half[1:(plat_n/2-top_n)]);
		resutls <- max(first_half[1:(plat_n/2-top_n)]) > min(second_half[1:(plat_n/2-top_n)]);
	}

	resutls
}

# input_dim_x=13; input_dim_y=3;
cnn.metric.batch.validation <- function(xtrain, ytrain, xtest, ytest, n_in_each_class_train,
	input_dim_x=13, input_dim_y=3, classes=classes, classn=classn, learningrate=0.1, iters=8000,
	beta.coe=1E-4, con_layer=4, is_shallow=TRUE)
{
	ptm_cnn <- proc.time();

	input_dim_stacked <- input_dim_x*input_dim_y;

	## option 4 taken 4% as validation
	train_test_file=paste(".//random.numbers//train_validation_file.", basename(filename), ".sample.rate", samplerate,".threshold", threshold, sep="");
	split.samples <- split.training.testing(train_test_file, classes, classn, n_in_each_class_train, ytrain, 0.96);
	train.index <- split.samples$train.index;
	validation.index  <- split.samples$test.index;

	meanx <- apply(xtrain, 2, mean);
	sdx   <- apply(xtrain, 2, sd);
	# x2 <- t((t(xtrain)-meanx)/sdx);
	# (xtrain[train.index,]-meanx)/sdx;
	dat.validation <- combine_xy_dat(  t((t(xtrain[validation.index,])-meanx)/sdx), ytrain[validation.index], classes);
	batch.validation <- next_batch(dat.validation, dim(dat.validation)[1], dimx=input_dim_stacked, n=dim(dat.validation)[1], classn);

	dat.train <- combine_xy_dat( t((t(xtrain[train.index,])-meanx)/sdx), ytrain[train.index], classes);
	dat.test  <- combine_xy_dat( t((t(xtest               )-meanx)/sdx), ytest , classes);

	# stop("I have to stop here");
	##**************************************
	## start to CNN
	totaln <- dim(dat.train)[1];
	totaln_test <- dim(dat.test)[1];
	cat("training n =", sprintf("%7d", totaln), "testing n =", totaln_test, "\n");
	batchsize <- 128;

	isdim <- FALSE;
	# isdim <- TRUE;

	##**************************************
	## start to build graph for train
	tf$reset_default_graph();
	x  <- tf$placeholder(tf$float32, shape(NULL, input_dim_stacked))
	y_ <- tf$placeholder(tf$float32, shape(NULL, classn))
	if (isdim) {
		index <- 1:100; ## RANDOM
		batch <- list("x_batch"=dat.train[index, 1:input_dim_stacked], "y_batch"=dat.train[index, (input_dim_stacked+1):(input_dim_stacked+classn)]);
		x <- tf$cast(batch[[1]], tf$float32);
	}

	bg_build_graph <- build_graph(con_layer, is_training=TRUE, x, input_dim_x, input_dim_y, is_norm=is_norm, is_shallow=is_shallow);

	y_conv_train <- bg_build_graph$y_conv;

	cross_entropy <- tf$reduce_mean(-tf$reduce_sum(y_ * tf$log(y_conv_train), reduction_indices=1L))

	## training option # 4
	momentum <- 0.9;
	train_step_lists <- list();

	rater <- 10;
	max_change_rate <- 4;
	max_change_rate <- ceiling(log10(learningrate/1E-6)) + 1;
	max_change_rate <- 5;
	# max_change_rate <- 1;
	cat("\tmax_change_rate =", max_change_rate, "\n");

	for (ti in 1:max_change_rate) train_step_lists[[ti]] <- tf$train$MomentumOptimizer(learningrate/rater^(ti-1), momentum)$minimize(tf$reduce_mean(cross_entropy + beta.coe * bg_build_graph$regularizer));

	# for (ti in 1:max_change_rate) train_step_lists[[ti]] <- tf$train$MomentumOptimizer(learningrate/rater^(ti-1), momentum)$minimize(tf$reduce_mean(cross_entropy) );

	##**************************************
	pred <- tf$argmax(y_conv_train, 1L);
	correct_prediction <- tf$equal(tf$argmax(y_conv_train, 1L), tf$argmax(y_, 1L));

	accuracy <- tf$reduce_mean(tf$cast(correct_prediction, tf$float32));

	##********************************************************************************************************************************************************
	## start to train CNN

	session_conf <- tf$ConfigProto(intra_op_parallelism_threads=MAX_THREADS, inter_op_parallelism_threads=MAX_THREADS);
	sess <- tf$InteractiveSession(config=session_conf);
	sess$run(tf$global_variables_initializer())
	saver <- tf$train$Saver();

	factor.batchsize <- 2;
	# factor.batchsize <- 4;
	# factor.batchsize <- 32*32;

	steps <- (iters/factor.batchsize);
	steps.validation <- ceiling(10/factor.batchsize*totaln/1590919)*100;
	if (totaln<50000) steps.validation <- 20;
	# steps.validation <- 50/factor.batchsize;
	# steps.validation <- 1024/factor.batchsize;
	cat("\tbatch size =", batchsize*factor.batchsize, "learning rate =", learningrate, "iterations =", iters, "MAX_THREADS =", MAX_THREADS, "steps.validation =", steps.validation, "\n");

	## steps
	accuracies <- vector(,  length=ceiling(iters/steps));
	kappas     <- vector(,  length=ceiling(iters/steps));
	accuracies.validation <- vector(,  length=ceiling(iters/factor.batchsize/steps.validation));
	accuracies.training   <- vector(,  length=ceiling(iters/factor.batchsize/steps.validation));
	learning.rates        <- vector(,  length=ceiling(iters/factor.batchsize/steps.validation));
	inner_i_validation <- 0;
	which_rate <- 1;
	# plat_accuracy <- 0.01;
	plat_n <- 12; last_change_i <- 0;
	# print(pop_mean)
	is_shuffle <- 0;
	batch_position <- totaln+1;

	for (i in 1:steps ) {
	# for (i in 1:(10) ) {
		## *********************************
		## next batch
		# batch <- next_batch(dat.train, totaln, dimx=input_dim_stacked, n=batchsize*factor.batchsize, classn);
		epoch <- ceiling (i*batchsize*factor.batchsize/totaln);
		if (batch_position>totaln ) {
			# if (epoch%%5==0) cat("\tData is shuffled:) at epoch", epoch, "\n");
			shuffle_index <- sample.int(totaln, totaln); batch_position = 1;
		}

		batch <- next_batch_with_shuffle (shuffle_index, dat.train, totaln, startx=batch_position, dimx=input_dim_stacked, n=batchsize*factor.batchsize, classn);
		batch_position <- batch_position + batchsize*factor.batchsize;

		## *********************************
		## determine whether to reduce the learning rate
		min_epoch <- 2;
		if ( (learningrate/rater^(which_rate-1)) >=0.01) min_epoch=30; # on May 14 for is_shallow=TRUE is good
		# if ( (learningrate/rater^(which_rate-1)) >=0.01) min_epoch=60; # on May 18 for is_shallow=TRUE is just OK

		if (
			(i-last_change_i)*batchsize*factor.batchsize/totaln>min_epoch ## min_epoch epochs
			&& which_rate<max_change_rate
			&& i%%steps.validation==0
			&& is_greater(accuracies.validation, inner_i_validation, plat_n)
		) {
			last_change_i <- i;
			which_rate <- which_rate+1;
			if (which_rate<=max_change_rate) cat("\n1.Note that the learning rate is reduced to", learningrate/rater^(which_rate-1), "in", i, "iteration \n");
		}
		# else if ( (i-last_change_i)*batchsize*factor.batchsize/totaln> (min_epoch+10) ## max_epoch epochs
		# ) {
			# last_change_i <- i;
			# which_rate <- which_rate+1;
			# if (which_rate<=max_change_rate) cat("\n2.Note that the learning rate is reduced to", learningrate/rater^(which_rate-1), "in", i, "iteration \n");
		# }
		which_rate <- min(max_change_rate, which_rate);

		## *********************************
		## gradient descent
		for (ti in 1:max_change_rate) if (ti==which_rate) train_step_lists[[ti]]$run(feed_dict = dict(x = batch[[1]], y_ = batch[[2]]));

		## *********************************
		## record/print training/validation output
		if (i%%steps.validation==0) {
			inner_i_validation <- i/steps.validation;
			accuracies.training[inner_i_validation] <- accuracy$eval(feed_dict = dict(x = batch[[1]], y_ = batch[[2]]));
			accuracies.validation[inner_i_validation] <- accuracy$eval(feed_dict = dict(x = batch.validation[[1]], y_ = batch.validation[[2]]));
			learning.rates[inner_i_validation] <- learningrate/rater^(which_rate-1);
			if(inner_i_validation%%20==0 || (inner_i_validation<20&&inner_i_validation%%10==0) ) cat(sprintf("  %7d, training accuracy %.4f, validation accuracy %.4f\n", i, accuracies.training[inner_i_validation], accuracies.validation[inner_i_validation]));
			if (accuracies.validation[inner_i_validation]<0.1) { cat("\n!!!SHIT happen again on i =", i, "\n");  break; }
		}

		## *********************************
		## record/print test output using the trained graph
		# if (i%%steps==0 || i==iters) {
			# ptm_cnn_i <- proc.time();
			# predicted  <- pred$eval(feed_dict = dict(x = dat.test[,1:(input_dim_stacked)]));
			# predicted2 <- predicted;

			## convert from a number from 1:n to class label
			# for ( ip in sort(unique(predicted)) ) predicted2[predicted==ip] <- classes[ip+1];
			# time.my <- proc.time() - ptm_cnn_i;
			# cat(paste("\n\tTest data time using train model", sprintf("%.3f",time.my[1]/3600),"\t", sprintf("%.3f",time.my[2]/3600),"\t", sprintf("%.3f",time.my[3]/3600),"hours\n"));

			# result <- confusion(predicted2, ytest);
			# inner_i <- i/steps;
			# kappas[inner_i] <- result$Kappa;
			# accuracies[inner_i] <- result$Accuracy;
		# }
	}
	time.train <- proc.time() - ptm_cnn;
	cat(paste("\nTraining  data time", sprintf("%.3f",time.train[1]/3600),"\t", sprintf("%.3f",time.train[2]/3600),"\t", sprintf("%.3f",time.train[3]/3600),"hours\n"));

	# for (i in 1:depth) print(sess$run(weightlists[[i]]) );

	plot.dir <- "./plot.dir/";
	if (! dir.exists(plot.dir)) {print(paste("Creating dir", plot.dir)); dir.create(plot.dir); }
	unique.file.name <- paste("DNN_type", con_layer, ".is_shallow", is_shallow, ".sample", samplerate,
		".learning", learningrate, ".is_norm", is_norm,
		".perm", permutation[1], ".beta", beta.coe,
		# ".max_change_rate", max_change_rate, "change_rate_ratio", rater,
		".iter", iters, ".max_change", max_change_rate, sep="");
	modir.dir <- paste0("./model.dir/",unique.file.name);
	if (! dir.exists(modir.dir)) {print(paste("Creating dir", modir.dir)); dir.create(modir.dir); }
	save(meanx, sdx, file=paste0(modir.dir,"//mean_std.rfile.data"))
	model.file.name <- paste(modir.dir, "/model.", unique.file.name, sep="");
	saver$save(sess, model.file.name);
	sess$close();

	save(samplerate, weightlists, kappas, accuracies, learning.rates, accuracies.validation, accuracies.training,
		file=paste(plot.dir, unique.file.name, sep="") );

	## ***********************************************************************************************
	## get prediction 1
	cat("\nStart up the testing model....\n");
	tf$reset_default_graph();
	x  <- tf$placeholder(tf$float32, shape(NULL, input_dim_stacked));
	bg_build_graph_test <- build_graph(con_layer, is_training=FALSE, x, input_dim_x, input_dim_y, is_norm=is_norm, is_shallow=is_shallow);
	y_conv_test <- bg_build_graph_test$y_conv;
	pred <- tf$argmax(y_conv_test, 1L);
	sess <- tf$InteractiveSession();
	sess$run(tf$global_variables_initializer())
	saver <- tf$train$Saver();
	saver$restore(sess, model.file.name);
	# cat("\tafter restore the saved model\n");
	ptm_cnn_i <- proc.time();
	predicted  <- pred$eval(feed_dict = dict(x = dat.test[,1:(input_dim_stacked)]));

	predicted2 <- predicted;
	for ( i in sort(unique(predicted)) ) predicted2[predicted==i] <- classes[i+1];	## convert from a number from 1:n to class label
	time.test <- proc.time() - ptm_cnn_i;
	cat(paste("\nTest data time", sprintf("%.3f",time.test[1]/3600),"\t", sprintf("%.3f",time.test[2]/3600),"\t", sprintf("%.3f",time.test[3]/3600),"hours\n"));

	sess$close();

	## ***********************************************************************************************
	## get confusion
	result <- confusion(predicted2, ytest, filename=paste(modir.dir, "cnn.temp", unique.file.name, ".csv", sep="") );

	result$train.time <- time.train/3600;
	result$test.time <- time.test/3600;
	result
}


args <- commandArgs(trailingOnly=T)
"%&%" <- function(a, b) paste(a, b, sep="")

hetfile <- args[1]

HET=read.table(hetfile,header=T,as.is=T)
H = (HET$N.NM.-HET$O.HOM.)/HET$N.NM.
pdf(file=hetfile %&% ".pdf")
oldpar=par(mfrow=c(1,2))
hist(H,50)
hist(HET$F,50)
par(oldpar)
dev.off()
HET[order(HET$F),]

outliers<-data.frame()

for(i in 1:length(HET$F)){
	if(HET[i,6] > (mean(HET$F)+3*sd(HET$F))){
		outliers <- rbind(outliers,HET[i,])
	}
	if(HET[i,6] < (mean(HET$F)-3*sd(HET$F))){
		outliers <- rbind(outliers,HET[i,])
	}
}

write.table(outliers,file=hetfile %&% ".outlier.list",quote=F,col.names=F,row.names=F)


compile_stan_file = function(stan_file){
	mod = cmdstanr::cmdstan_model(
		stan_file
		, include_paths = './stan_code'
		, dir = './stan_temp'
	)
	return(mod)
}

generate_true_and_data = function(n,k,iteration,stan_mod_for_generating){
	gen_args = tibble(n,k,iteration)
	data_for_stan = lst(n,k)
	gq = stan_mod_for_generating$generate_quantities(
		data = data_for_stan
		, fitted_params = posterior::as_draws_array(tibble(dummy_=0))
		, seed = abs(digest::digest2int(digest::digest(gen_args,algo='xxhash64')))
	)
	#add generated y to data (probably a more straight-forward way to do this!)
	(
		gq$draws('y')
		%>% posterior::as_draws_rvars()
		%>% (function(y){
			posterior::draws_of(y$y)[1,,]
		})
	) -> data_for_stan$y
	#get parameters
	(
		gq$draws()
		%>% posterior::as_draws_df()
		%>% as_tibble()
		%>% select(-.chain,-.iteration,-.draw)
		%>% pivot_longer(everything())
		%>% filter(
			!str_starts(name,'y')
		)
		%>% rename(true=value)
	) -> true_pars
	#bundle for output
	lst(
		gen_args
		, true_pars
		, data_for_stan
	) -> generated
	return(generated)
}


set.seed(1234)

R2_bootstrap <- function(model, n.sim = 10000) {
  # bootstrap n.sim times to calc pseudo r-squared values:
  lmer_bs <- bootMer(model, FUN=function(x)r.squaredGLMM(x),
                nsim=n.sim)

  # calculate median and 0.025,0.975 percentiles for R2c and R2m:
  lmer_bs_R2 <- as.data.frame(lmer_bs$t) %>%
    rownames_to_column(var = "type_R2") %>%
    rename(R2=V1) %>%
    mutate(type_R2 = substr(type_R2,1,3)) %>%
    group_by(type_R2) %>%
    mutate(median = median(R2),
           ll = quantile(R2,0.025),
           ul = quantile(R2, 0.975))

  # return bootstrap data:
  return(lmer_bs_R2)
}


  variable.recode = function( x, variable, direction="forward", rm.na=F, lookup.table=NULL, p=NULL ) {

    if (is.null(lookup.table)) lookup.table = snowcrab.db( DS="data.transforms", p=p)

    ii = which( lookup.table$varname == variable )
    if (length(ii) == 0 ) { # missing from list .. print error message and stop to figure out why
      # print( paste("Recode:", variable, "is missing from database, assuming no transformation"))
      # tmp = lookup.table[1,]
      # tmp[1,] = c(variable, "none", 0, 1 )
      return( x )
    } else if ( length(ii) > 1 ) {
      print(paste( "Error in recode:", variable, "has too many incidences in database"))
      stop()
    }

    TF = lookup.table[ii ,]
    if ( TF$transform %in% c("", "none") ) {
      B = x
    }

    if ( TF$transform == "log10") {
      if (direction =="forward") {
        B = log10( x + TF$offset )
      } else if (direction =="backward") {
        B = 10^x - TF$offset
      }
    }

    if ( TF$transform == "scaled+centered") {
      if (direction =="forward") {
        B = scale( x, center=TF$offset, scale=TF$scaling )
      } else if (direction=="backward" ) {
        B = fields::unscale( x, x.center=TF$offset, x.scale=TF$scaling )
      }
    }

    if (rm.na) B = B[which(is.finite(B))]

    return (B)
  }


library(readxl)

setwd ("c://R")
LicDrivers <- read_excel("LicensedDrivers.xlsx")

str(LicDrivers)

LModel = lm(LicensedDrivers~Year,data = LicDrivers)

plot(LicDrivers$Year,LicDrivers$LicensedDrivers,cex = 1.3,lwd = 10)
abline(LModel,lwd=5)

summary(LModel)

names(LModel)
LModel$coefficients
LModel$residuals
stem (LModel$residuals)
LModel$fitted.values

plot(LModel,which=1)
plot(LModel,which=2)
plot(LModel,which=3)
plot(LModel,which=5)


Reduce('+', c(2,30,400,5000))
5432


library(CompQuadForm)
library(nFactors)

###############################
path1 = '.';

source(file = paste(path1, "/ASKAT.R", sep=""))
source(file = paste(path1, "/Geno.FaST.LMM.R", sep=""))
source(file = paste(path1, "/Get_Lambda.R", sep=""))
source(file = paste(path1, "/Get_PValue.Modif.R", sep=""))
source(file = paste(path1, "/pheno.geno.kin.Without.NA.R", sep=""))
source(file = paste(path1, "/VC.FaST.LMM.R", sep=""))

load(paste(path1, "/kinsip4000SNPs.RData", sep=""))

Ped.pheno.Geno = read.table(paste(path1, "/Ped4ASKAT.dat", sep=""), header=FALSE)
Y.trait = Ped.pheno.Geno[,2]
Missing = FALSE
GenoAll = Ped.pheno.Geno[,3:dim(Ped.pheno.Geno)[2]]

IDs = c(1:length(Y.trait))
wp1 = seq(0, dim(GenoAll)[2], by = 10)

p.value.ASKAT = vector(length = (length(wp1)-1))

#for (i in 1:(length(wp1)-1)){
for (i in c(1, 101, 201, 301, 401) ) {
	Ped = cbind(IDs, Y.trait, GenoAll[,(wp1[i]+1):wp1[i+1]])
	resultats = ASKAT(Ped, kin1, Missing)
	p.value.ASKAT[i] = resultats$pvalue.ASKAT
	cat('Index: ', i, '\t[', wp1[i]+1, ',' , wp1[i+1] , ']\t' , 'pvalue: ', p.value.ASKAT[i] ,'\n')
}

p.value.ASKAT
write.table(p.value.ASKAT, file = "pvalueASKAT1.dat", sep = " ", quote = FALSE, row.names = FALSE, col.names = FALSE)

log.pval.Obs1 = sort(- log10(p.value.ASKAT), decreasing = T)
p= length(log.pval.Obs1)
log.pval.Exp = - log10(c(1:p)/(p+1))

pdf("QQplotSimDATA_ASKAT1.pdf")
plot(log.pval.Exp, log.pval.Obs1, xlim = c(0,13), ylim = c(0,13), ylab = expression("-log10(Obs p-value)"), xlab = "-log10(Exp p-value)", main= paste("ASKAT, ", p, " Windows, 10 SNPs in each W", sep=""))
abline(0,1)
dev.off()