# "Performance Mid to higher severity"

# Setting
```{r}

# reset
rm(list=ls(all=TRUE))

# library
library(data.table)
library(dplyr)
library(psych)
library(caret)
library(gam)
library(RSNNS)
library(e1071)
library(ranger)
library(randomForest)
library(xgboost)

# Directory
setwd(".")

# Get data
Data <- fread("Data_demo.csv", encoding = "UTF-8" )
Data$V1 <- NULL

# Train Test
Data_train <- Data[TrainTest == "Train", , ] #*eligible
Data_train <- data.frame(Data_train)

Data_test <- Data[TrainTest == "Test", , ] #*eligible
Data_test <- data.frame(Data_test)

```

# define functions
```{r}

RMSE <- function(Obs, Pred){
	Dif <- Pred - Obs
	RMSE <- round(sqrt(mean(Dif**2)), 2)
	return(RMSE)
}

MAE <- function(Obs, Pred){
	Dif <- Pred - Obs
	MAE <- Dif %>% abs() %>% mean()	%>% round(., 2)
	return(MAE)
}

MAPE <- function(Obs, Pred){
	Dif <- Pred - Obs
	MAPE <- mean(abs(Dif/Obs)*100) %>% round(., 2)
	return(MAPE)
}

```

# Performance All SeverityHigherMid in Train and Test
```{r}

Models <- c(
	"glm_uni.rds"
	, "GLM_temp.rds"
	, "gamSpline_temp.rds"
	, "RF_temp.rds"
	, "xgbTree_temp.rds"
)

# get model list
Model_list <- Models

# Save performance
Hoge <- c()

# loop
for(iii in Model_list){

# load models
Model <- readRDS(iii)

# get predicted values
Data_train$Pred <- if(iii == "glm_uni.rds"){Data_train$Pred <- predict(Model, Data_train, type = "response")}else{Data_train$Pred <- predict(Model, Data_train)}
Data_train$Pred <- ifelse(Data_train$Pred < 0, 0, Data_train$Pred)

# get performance
RMSE_train <- RMSE(Obs = Data_train$SeverityHigherMid, Pred = Data_train$Pred)

MAE_train <- MAE(Obs = Data_train$SeverityHigherMid, Pred = Data_train$Pred)

Cor_train <- paste(
	cor.test(Data_train$SeverityHigherMid, Data_train$Pred)$estimate %>% round(., 2),
	" (",
	cor.test(Data_train$SeverityHigherMid, Data_train$Pred)$conf.int[1] %>% round(., 2),
	" to ",
	cor.test(Data_train$SeverityHigherMid, Data_train$Pred)$conf.int[2] %>% round(., 2),
	")",
	sep = ""
	)

# get predicted values
Data_test$Pred <- if(iii == "glm_uni.rds"){Data_test$Pred <- predict(Model, Data_test, type = "response")}else{Data_test$Pred <- predict(Model, Data_test)}
Data_test$Pred <- ifelse(Data_test$Pred < 0, 0, Data_test$Pred)

# get performance
RMSE_test <- RMSE(Obs = Data_test$SeverityHigherMid, Pred = Data_test$Pred)

MAE_test <- MAE(Obs = Data_test$SeverityHigherMid, Pred = Data_test$Pred)

Cor_test <- paste(
	cor.test(Data_test$SeverityHigherMid, Data_test$Pred)$estimate %>% round(., 2),
	" (",
	cor.test(Data_test$SeverityHigherMid, Data_test$Pred)$conf.int[1] %>% round(., 2),
	" to ",
	cor.test(Data_test$SeverityHigherMid, Data_test$Pred)$conf.int[2] %>% round(., 2),
	")",
	sep = ""
	)

# Summarize
Performance <- c(
	iii,
	RMSE_train
	, RMSE_test

	, Cor_train
	, Cor_test
	)

Hoge <- cbind(Hoge, Performance)

}

Hoge <- data.table(Hoge)
Hoge

fwrite(Hoge, "Out_RMSE.csv")

```

# MAPE by 24
```{r}

# get model list
Model_list <- Models

# Save performance
Hoge <- c()

# loop
for(iii in Model_list){

# load models
Model <- readRDS(iii)

# get predicted values
Data_train$Pred <- if(iii == "glm_uni.rds"){Data_train$Pred <- predict(Model, Data_train, type = "response")}else{Data_train$Pred <- predict(Model, Data_train)}
Data_train$Pred <- ifelse(Data_train$Pred < 0, 0, Data_train$Pred)

# Organized dataset
Data_train_MAPE <- Data_train %>%
	group_by(Date) %>%
	summarise(
		Obs = sum(SeverityHigherMid),
		Pred = sum(Pred)
		) %>% data.table()

Data_train_MAPE[, Year := year(Date), ]

Data_train_MAPE[, Spike :=
	ifelse(Year == 2015 & Obs >= Data_train_MAPE[Year == 2015, quantile(Obs, 0.8), ], 1,
	ifelse(Year == 2016 & Obs >= Data_train_MAPE[Year == 2016, quantile(Obs, 0.8), ], 1,
	ifelse(Year == 2017 & Obs >= Data_train_MAPE[Year == 2017, quantile(Obs, 0.8), ], 1, 0)))
	, ]
Data_train_MAPE[, table(Spike), ]
Data_train_MAPE[, table(Spike), ] / nrow(Data_train_MAPE)

# get performance
MAPE_train <- MAPE(
	Obs = Data_train_MAPE[Spike == 1, Obs, ],
	Pred = Data_train_MAPE[Spike == 1, Pred, ]
	)

PE_train <- Data_train_MAPE[Spike == 1, round( (abs(sum(Pred) - sum(Obs)) / sum(Obs) ) * 100, 2), ]

# get predicted values
Data_test$Pred <- if(iii == "glm_uni.rds"){Data_test$Pred <- predict(Model, Data_test, type = "response")}else{Data_test$Pred <- predict(Model, Data_test)}
Data_test$Pred <- ifelse(Data_test$Pred < 0, 0, Data_test$Pred)

# Organized dataset
Data_test_MAPE <- Data_test %>%
	group_by(Date) %>%
	summarise(
		Obs = sum(SeverityHigherMid),
		Pred = sum(Pred)
		) %>% data.table()

Data_test_MAPE[, Year := year(Date), ]

Data_test_MAPE[, Spike :=
	ifelse(Year == 2018 & Obs >= Data_test_MAPE[Year == 2018, quantile(Obs, 0.8), ], 1, 0)
	, ]
Data_test_MAPE[, table(Spike), ]
Data_test_MAPE[, table(Spike), ] / nrow(Data_test_MAPE)

# get performance
MAPE_test <- MAPE(
	Obs = Data_test_MAPE[Spike == 1, Obs, ],
	Pred = Data_test_MAPE[Spike == 1, Pred, ]
	)

PE_est <- Data_test_MAPE[Spike == 1, round( (abs(sum(Pred) - sum(Obs)) / sum(Obs) ) * 100, 2), ]

# Summarize
Performance <- c(
	iii,
	MAPE_train
	, MAPE_test

	, PE_train
	, PE_est
	)

Hoge <- cbind(Hoge, Performance)

}

Hoge <- data.table(Hoge)
Hoge

fwrite(Hoge, "Out_MAPE_24.csv")

```

# Figure time series by 24h
```{r}

# get model list
Model_list <- Models

# Save performance
Hoge <- c()

# loop
for(iii in Model_list){

# load models
Model <- readRDS(iii)

# get predicted values
Data_train$Pred <- if(iii == "glm_uni.rds"){Data_train$Pred <- predict(Model, Data_train, type = "response")}else{Data_train$Pred <- predict(Model, Data_train)}
Data_train$Predicted <- ifelse(Data_train$Pred < 0, 0, Data_train$Pred)

Data_train$Obserbved <- Data_train$SeverityHigherMid
Data_train$Dif <- Data_train$Predicted - Data_train$Obserbved

# get predicted values
Data_test$Pred <- if(iii == "glm_uni.rds"){Data_test$Pred <- predict(Model, Data_test, type = "response")}else{Data_test$Pred <- predict(Model, Data_test)}
Data_test$Predicted <- ifelse(Data_test$Pred < 0, 0, Data_test$Pred)

Data_test$Obserbved <- Data_test$SeverityHigherMid
Data_test$Dif <- Data_test$Predicted - Data_test$Obserbved

### Make figures
ggplot(data = Data_train, aes(x = Predicted, y = Obserbved)) +
	geom_point() +
	geom_smooth(method = lm) +
	scale_x_continuous(limits = c(0, 40), breaks = seq(0, 40, 5)) +
	scale_y_continuous(limits = c(0, 40), breaks = seq(0, 40, 5)) +
	xlab("") +
	ylab("") +
	theme_classic()
ggsave(paste("Out_plot_", iii, "_train.png", sep = ""), width = 4.2, height = 3.2) #*action

### Make figures taest
ggplot(data = Data_test, aes(x = Predicted, y = Obserbved)) +
	geom_point() +
	geom_smooth(method = lm) +
	scale_x_continuous(limits = c(0, 40), breaks = seq(0, 40, 5)) +
	scale_y_continuous(limits = c(0, 40), breaks = seq(0, 40, 5)) +
	xlab("") +
	ylab("") +
	theme_classic()
ggsave(paste("Out_plot_", iii, "_test.png", sep = ""), width = 4.2, height = 3.2) #*action

### Make Fig train
DataSum_train <- Data_train %>%
	group_by(Date) %>%
	summarise(
		Obserbved = sum(Obserbved),
		Predicted = sum(Predicted)
		) %>%
	data.table() %>%
	print()

DataSum_test <- Data_test %>%
	group_by(Date) %>%
	summarise(
		Obserbved = sum(Obserbved),
		Predicted = sum(Predicted)
		) %>%
	data.table() %>%
	print()

DataSum <- rbind(DataSum_train, DataSum_test)

DataSum[, Date:=as.Date(Date), ]
DataSum[, YearUse:=year(Date), ]
DataSum <- DataSum[order(Date), , ]
DataSum[, Day:=1:length(Obserbved), by = YearUse]
DataSum

DataSum[Date == as.Date("2015-06-01"), , ]
DataSum[Date == as.Date("2015-07-01"), , ]
DataSum[Date == as.Date("2015-08-01"), , ]
DataSum[Date == as.Date("2015-09-01"), , ]

ggplot(data = DataSum, aes(x = Day), group=factor(YearUse)) +
	geom_line(aes(y = Obserbved, x=Day), colour = "Black", size = 0.4) +
	geom_line(aes(y = Predicted, x=Day), colour = "Red", size = 0.4) +
	xlab("") +
	ylab("") +

	scale_y_continuous(
		limits = c(0, 150),
		breaks = seq(0, 150, 30)
		) +

	scale_x_continuous(
		label = c("Jun.", "Jul.", "Aug.", "Sep."),
		breaks = c(1, 31, 62, 93)
		) +
	theme(axis.text.x = element_text(angle = 90, hjust = 1)) +
	facet_grid(~YearUse) +
	theme_classic()

ggsave(paste("Out_time_24_", iii, ".png", sep = ""), width = 6.7 * 1.5, height = 3.5 * 0.66) #*action

fwrite(DataSum, paste("Out_data_figure4_", iii, ".csv", sep = ""))

}

Hoge <- data.table(Hoge)
Hoge

```


library(rgdal) #
library(rgeos) #

### Đọc
Output.Areas<- readOGR("./Camden_oa11", "Camden_oa11")
plot(Output.Areas)

source("2-EDA.r")

OA.Census <- merge(Output.Areas, Census.Data, by.x="OA11CD", by.y="OA")

#setting coordinate system

# sets the coordinate system to the British National Grid
proj4string(OA.Census) <- CRS("+init=EPSG:27700")

#Mapping Data

# loads packages
library(tmap)
library(leaflet)

# this will prodyce a quick map of our qualification variable
qtm(OA.Census, fill = "Qualification")

# Creates a simple choropleth map of our qualification variable
tm_shape(OA.Census)+tm_fill("Qualification")

library(RColorBrewer)

#display.brewer.all()

tm_shape(OA.Census) + tm_fill("Qualification", palette = "-Greens")

# changing the intervals
tm_shape(OA.Census) + tm_fill("Qualification", style = "quantile", palette = "Reds")

# number of levels
tm_shape(OA.Census) + tm_fill("Qualification", style = "quantile", n = 7, palette = "-Greens")

# includes a histogram in the legend
tm_shape(OA.Census) + tm_fill("Qualification", style = "quantile", n = 5, palette = "Reds", legend.hist = TRUE)

# add borders
tm_shape(OA.Census) + tm_fill("Qualification", palette = "Reds") +
  tm_borders(alpha=.4)

# north arrow
tm_shape(OA.Census) + tm_fill("Qualification", palette = "Reds") +
  tm_borders(alpha=.4) +
  tm_compass()

# adds in layout, gets rid of frame
tm_shape(OA.Census) + tm_fill("Qualification", palette = "Reds", style = "quantile", title = "% with a Qualification") +
  tm_borders(alpha=.4) +
  tm_compass() +
  tm_layout(title = "Camden, London", legend.text.size = 1.1, legend.title.size = 1.4, legend.position = c("right", "top"), frame = FALSE)

#writeOGR(OA.Census, dsn = "./week1-practice/Camden", layer =  "Census_OA_Shapefile", driver="ESRI Shapefile")

#library(raster)
#OA.Census$area <- area(OA.Census)


source("mlp.r")

test <- function(dataset=dataset, eta=0.2){
    #dataset = cbind(rnorm(mean=0, sd=1, n=100), rnorm(mean=0, sd=1, n=100), 0)
    #dataset = rbind(dataset, cbind(rnorm(mean=0, sd=1, n=100), rnorm(mean=1, sd=1, n=100), 1))
    dataset = read.csv('dataset.csv', header=F, skip=1)
    dataset = rbind(dataset, read.csv('dataset.csv', header=F, skip=1))

    plot(dataset[,1:2], col=dataset[,3]+1)
    locator(1)

    ids = sample(1:nrow(dataset), size=150)
    train = dataset[ids,]
    test = dataset[-ids,]

    for(hyp in 1:10){
        #model = mlp.architecture(input.length=2, output.length=1, hidden.length=hyp)
        #trained = mlp.backpropagation(model=model, dataset=train, eta=eta)
        model = mlp.architecture(input.length=14, output.length=1, hidden.length=hyp)
        trained = mlp.backpropagation(dataset=train, model=model, eta=eta)

        wrong = 0
        for(j in 1:nrow(test)){
            x = test[j, 1:2]
            y.e = as.numeric(test[j, 3])
            y.o = round(mlp.forward(model=trained$model, Xp=x)$f_net_o_p)
            if(y.e != y.o){
                wrong = wrong + 1
            }
        }
        error = wrong / nrow(test)
        cat(hyp, "\t", error, "\n")
    }

}


#### covidWBE.r
#### Nick Crosbie, May 2020
#### source("./bin/covidWBE.r")

library(EnvStats)

# WASTEWATER CATCHMENT (calculate dry weather flow in millilitres per day)
catchmentPop <- 10^4 # number of people in catchment
dryWeatherFlowPerPerson <- 2.12799e-4 # dry weather flow contributed by each person, in ** megalitres ** per day (average derived from all participating ColoSSoS WWTP catchments)
dryWeatherFlow_MLD <- catchmentPop * dryWeatherFlowPerPerson # catchment dry weather flow, in ** megalitres ** per day
dryWeatherFlow_mLD <- dryWeatherFlow_MLD * 1e9 # catchment dry weather flow, in ** millilitres ** per day

# SARS-CoV-2 GENOMES SHED PER DAY TO CATCHMENT BY DEFECATION (number of genomes)
modeShed <- 10^3 # mode number of genomes shed in faecies by an infected person (genomes per millilitre of faecies)
minShed <- 10^2 # min number of genomes shed in faecies by an infected person (genomes per millilitre of faecies)
maxShed <- 10^7 # max number of genomes shed in faecies by an infected person (genomes per millilitre of faecies)

defVol <- 200 # volume of faecies defacated per day by an individual, in millilitres (no distinction made between volume defecated by infected and non-infected individuals)
numberShedding <- 1 # number of people shedding in catchment
defVolInfCat <- defVol * numberShedding #  combined volume of faecies defacated by shedders per day, in millilitres

modeShedCat <- modeShed * defVolInfCat # mode number of genomes shed per day to catchment by infected population
minShedCat <- minShed * defVolInfCat # minimum number of genomes shed per day to catchment by infected population
maxShedCat <- maxShed  * defVolInfCat # maximum number of genomes shed per day to catchment by infected population

# TRIANGULAR DISTRIBUTION OF SARS-CoV-2 GENOMES SHED PER DAY TO CATCHMENT BY DEFECATION (number of genomes)
triagShedCat <- simulateVector(n = 10000, distribution = "tri", param.list = list(min = minShedCat, mode = modeShedCat, max = maxShedCat),
sample.method = "LHS", seed = 47)

pdfPlot(distribution = "tri", param.list = list(min = minShedCat, mode = modeShedCat, max = maxShedCat), n.points = 10000)

# SARS-CoV-2 CONCENTRATION AT POINT OF WASTEWATER SUBSAMPLING (genomes per mL)
catchmentDilution <- defVolInfCat / dryWeatherFlow_mLD
wastewaterConc <- triagShedCat * catchmentDilution # genomes per mL of catchment wastewater, ** assuming fully mixed catchment **

# plot(ecdf(wastewaterConc))

# SARS-CoV-2 CONCENTRATION OF FINAL CONCENTRATED PREPARATION
concFactor <- 4  # concentration factor from point of wastewater sampling to final concentrated preparation
finalPrepConc <- wastewaterConc * concFactor # virus concentration prior to subsampling for PCR (genomes per millilitre)

#plot(ecdf(finalPrepConc))

# SARS-CoV-2 GENOMES PER PCR REACTION (number of genomes)
finalConcVol <- 2 # volume of sample prior to subsampling for PCR reaction, in millilitres
genomesFinalPrep <- finalPrepConc * finalConcVol # number of genomes contained in the final prep (step immediately prior to PCR)

templateVol <- 0.005 # volume in which the final preparation is resuspended prior to pipetting to PCR reaction
volRxn <- 0.05 # volume of one PCR reaction, in millilitres (i.e. 50 microlitres)
genomesRxn <- genomesFinalPrep * (templateVol/volRxn) # genomes per reaction
LOD <- 10 # PCR limit of detection as genomes per reaction

n <- 10000 # number of wastewater samples analysed for SARS-CoV-2
detects <- sum(genomesRxn > LOD) # number of SARS-CoV-2 detects
trueDetectProportion <- 0.90 # proportion of detects that are true positives
percentRealDetects <- ((detects * trueDetectProportion) / n) * 100 # percentage of samples where SARS-CoV-2 is detected

print(percentRealDetects)

# plot(ecdf(genomesRxn))


#' Aligning text.
#'
#' A helper function for \code{diffr()} that uses a distance matrix to align
#' text lines.
#'
#' Gives back an alignment matrix (boolean) or an data frame with line numbers.
#'
#' @param distM Distance matrix to base alignment on.
#' @param maxDist Maximum distance below which two lines might be considered to
#'   match.
#' @param retMatrix Should the result be returned as boolean matrix or as data
#'   frame.
#' @export

text_align <- function(distM, maxDist=Inf, retMatrix=T){
  # evaluating maxDiff option to numeric max distance
  md     <- choose_maxdist_option(distM, maxDist)
  distM[ distM > md ]  <- Inf

  # some general variables and preparations
  nrows  <- dim(distM)[1]
  ncols  <- dim(distM)[2]
  rows   <- seq_len(nrows)
  cols   <- seq_len(ncols)
  rownames(distM) <- rows
  colnames(distM) <- cols

  used_cols <- rep(FALSE, ncols)
  used_rows <- rep(FALSE, nrows)
  AlignM    <- matrix(FALSE, nrows, ncols)
  rowset    <- rows[apply(distM, 1, min) == min(distM) & min(distM)!=Inf]

  # align lines in ...
  # 1. inverse order of distance;
  # 2. order of appearance in text
  while (length(rowset)>0) {
    for( i in rowset ){
      rowmin    <- min(distM[i,])
      distances <- distM[i,]
      align <- seq_len(ncols)[rowmin == distances & !used_cols][1]
      used_cols[align] <- TRUE
      used_rows[i]     <- TRUE
      AlignM[i,align]  <- TRUE
    }
    unused_rows <- rows[!used_rows]
    unused_cols <- cols[!used_cols]
    unused_matr <- distM[unused_rows, unused_cols, drop=F]
    if ( any(dim(unused_matr)==0) | all(unused_matr==Inf)) {
      rowset <- NULL
    }else{
      rowset      <- as.numeric(rownames(unused_matr)[
        apply(unused_matr, 1, min) == min(unused_matr)])
    }
  }

  if(retMatrix){
    AlignM
  }else{
    align_matrix_to_align_df(AlignM, distM=distM)
  }
}


#==============================================================================
#	Functions used for MESS.
#==============================================================================

#------------------------------------------------------------------------------
#'	(Internal) Calculate distance between test and training data using MESS
#'
#'	This function calculate multivariate environmental similarity surface
#'	(MESS, Elith, Kearney and Phillips 2010) for each point in test data.
#'
#'	@param data.train a data.frame containing training data.
#'	@param data.test a data.frame containing test data.
#'	@param na.rm a logical indicating ignorance of NA.
#'
#'	@section References:
#'	Elith, J., M. Kearney, and S. Phillips. 2010.
#'	The art of modelling range-shifting species.
#'	Methods in Ecology and Evolution 1:330-342.
#------------------------------------------------------------------------------
calculate.mess <- function(data.train, data.test, na.rm = TRUE) {
	# Prepare matrix for the result.
	numeric.columns <- colnames(data.test)[sapply(data.test, is.numeric)]
	similarity <- matrix(
		NA, nrow = nrow(data.test), ncol = length(numeric.columns)
	)
	colnames(similarity) <- numeric.columns
	# Iterate over numeric columns.
	for (i in numeric.columns) {
		# min_i
		min.i <- min(data.train[[i]], na.rm = na.rm)
		# max_i
		max.i <- max(data.train[[i]], na.rm = na.rm)
		# f_i for all p_i
		smaller.fraction <- sapply(
			data.test[[i]],
			function(x) mean(data.train[[i]] < x, na.rm = na.rm) * 100
		)
		# Similarity: f_i = 0
		case_0 <- (data.test[[i]] - min.i) / (max.i - min.i) * 100
		# Similarity: 0 < f_i <= 50
		case_0_50 <- 2 * smaller.fraction
		# Similarity: 50 <= f_i < 100
		case_50_100 <- 2 * (100 - smaller.fraction)
		# Similarity: f_i = 100
		case_100 <- (max.i - data.test[[i]]) / (max.i - min.i) * 100
		similarity[, i] <- ifelse(
			smaller.fraction == 0, case_0,
			ifelse(
				smaller.fraction <= 50, case_0_50,
				ifelse(smaller.fraction < 100, case_50_100, case_100)
			)
		)
	}
	return(apply(similarity, 1, min))
}

#------------------------------------------------------------------------------
#'	Create a function calculate MESS of a group.
#'
#'	This function creates a function which calculate aggregated MESS for a
#'	group of points.
#'
#'	@param columns
#'		names of columns or index of columns used for calculation of MESS.
#'	@param aggregate.fun
#'		a function used for aggregation of values of MESS of a group.
#'		Functions like \code{mean}, \code{median}, \code{max} and \code{min}
#'		as well as other functions which accept vector of values and return
#'		single value can be used.
#'	@param na.rm
#'		logical indicating whether NA values should be ignored during
#'		calculation of MESS.
#'	@param ...
#'		other arguments passed for \code{aggregate.fun}.
#'
#'	@export
#------------------------------------------------------------------------------
mess <- function(columns = NULL, aggregate.fun = mean, na.rm = TRUE, ...) {
	f <- function(data.train, data.test) {
		if (!is.null(columns)) {
			data.train <- data.train[columns]
			data.test <- data.test[columns]
		}
		return(
			aggregate.fun(calculate.mess(data.train, data.test, na.rm), ...)
		)
	}
	return(f)
}

#==============================================================================
#	Functions and data used for geographic distance.
#==============================================================================

#------------------------------------------------------------------------------
#'	(Internal) Parameters for several earth ellipsoids.
#------------------------------------------------------------------------------
ELLIPSOIDS = list(
    grs80 = list(
        semi.major.axis.m = 6378137,
        semi.minor.axis.m = 6356752.3141403561,
        inverse.flattening = 298.25722210100002
	),
    wgs84 = list(
        semi.major.axis.m = 6378137,
        semi.minor.axis.m = 6356752.3142451793,
        inverse.flattening = 298.25722356300003
	),
    bessel1841 = list(
        semi.major.axis.m = 6377397.1550000003,
        semi.minor.axis.m = 6356078.9628181886,
        inverse.flattening = 299.15281279999999
	)
)

#------------------------------------------------------------------------------
#'	(Internal) Convert degree to radian.
#'
#'	@param x values in degree.
#------------------------------------------------------------------------------
deg2rad <- function(x) {
	return(x / 180 * pi)
}

#------------------------------------------------------------------------------
#'	(Internal) Find parameters for the Vincenty's formulae.
#'
#'	@param f
#'		flattening of the ellipsoid.
#'	@param L
#'		difference in longitude of two points.
#'	@param U1
#'		reduced latitude (latitude on the auxiliary sphere) of point 1.
#'	@param U2
#'		reduced latitude (latitude on the auxiliary sphere) of point 2.
#'	@param threshold
#'		threshold difference to determine convergence.
#'		The value of 1e-12 produces precision of 0.06mm.
#'	@param maxit
#'		maximum number of iteration to test convergence.
#------------------------------------------------------------------------------
find.vincenty.parameters <- function(f, L, U1, U2, threshold, maxit) {
	lambda.prev <- lambda <- L
	for (i in 1:maxit) {
		sin.sigma <- sqrt(
			(cos(U2) * sin(lambda)) ^ 2
			+ (cos(U1) * sin(U2) - sin(U1) * cos(U2) * cos(lambda)) ^ 2
		)
		cos.sigma <- sin(U1) * sin(U2) + cos(U1) * cos(U2) * cos(lambda)
		sigma <- atan2(sin.sigma, cos.sigma)
		sin.alpha <- cos(U1) * cos(U2) * sin(lambda) / sin.sigma
		cos2.alpha <- 1 - sin.alpha ^ 2
		cos.2sigma.m <- cos.sigma - (2 * sin(U1) * sin(U2) / cos2.alpha)
		C <- f / 16 * cos2.alpha * (4 + f * (4 - 3 * cos2.alpha))
		lambda <- (
			L + (1 - C) * f * sin.alpha * (
				sigma + C * sin.sigma * (
					cos.2sigma.m + C * cos.sigma * (
						-1 + 2 * (cos.2sigma.m ^ 2)
					)
				)
			)
		)
		if (all(abs(lambda - lambda.prev) <= threshold)) {
			break
		}
		lambda.prev <- lambda
	}
	if (i == maxit) {
		stop(
			"Couldn't determine distance(s).\n",
			"Try increasing the value of 'maxit'."
		)
	}
	result <- list(
		sigma = sigma, sin.sigma = sin.sigma, cos.sigma = cos.sigma,
		cos2.alpha = cos2.alpha, cos.2sigma.m = cos.2sigma.m
	)
	return(result)
}

#------------------------------------------------------------------------------
#'	(Internal) Calculate distance using the Vincenty's formulae.
#'
#'	@param a
#'		semi major axis length in m.
#'	@param b
#'		semi minor axis length in m.
#'	@param lon1
#'		vector of longitude (x) of point 1 in radian.
#'	@param phi1
#'		vector latitude (y) of point 1 in radian.
#'	@param lon2
#'		vector of longitude (x) of point 2 in radian.
#'	@param phi2
#'		vector of latitude (y) of point 2 in radian.
#'	@param threshold
#'		threshold difference to determine convergence.
#'		The value of 1e-12 produces precision of 0.06mm.
#'	@param maxit
#'		maximum number of iteration to try before convergence.
#'
#'	@section References:
#'		Vincenty, T. (1975)
#'		Direct and inverse solutions of geodesics on the ellipsoid with
#'		application of nested equations. Survey Review 23:88-93.
#------------------------------------------------------------------------------
vincenty.distance <- function(
	a, b, lon1, phi1, lon2, phi2, threshold = 1e-12, maxit = 1000
) {
	# Prepare parameters.
	f <- (a - b) / a
	U1 <- atan((1 - f) * tan(phi1))
	U2 <- atan((1 - f) * tan(phi2))
	L <- lon2 - lon1
	# Find the Vincenty's formulae's parameters.
	params <- find.vincenty.parameters(f, L, U1, U2, threshold, maxit)
	# Calculate distances.
	mu2 <- params$cos2.alpha * (a ^ 2 - b ^ 2) / b ^ 2
	A <- 1 + mu2 / 16384 * (4096 + mu2 * (-768 + mu2 * (320 - 175 * mu2)))
	B <- mu2 / 1024 * (256 + mu2 * (- 128 + mu2 * (74 - 47 * mu2)))
	delta.sigma <- B * params$sin.sigma * (
		params$cos.2sigma.m
		+ B / 4 * (
			params$cos.sigma * (-1 + 2 * params$cos.2sigma.m ^ 2)
			- B / 6 * (
				params$cos.2sigma.m * (-3 + 4 * params$sin.sigma ^ 2)
				* (-3 + 4 * params$cos.2sigma.m ^ 2)
			)
		)
	)
	s <- b * A * (params$sigma - delta.sigma)
	return(s)
}

#------------------------------------------------------------------------------
#'	Create a function calculates geographic distance.
#'
#'	@param x.name
#'		column name of longitude.
#'		Data should be stored in decimal degree.
#'	@param y.name
#'		column name of latitutde.
#'		Data should be stored in decimal degree.
#'	@param ellipsoid
#'		name of earth ellipsoids, can be "grs80", "wgs84" or "bessel1841".
#'	@param method
#'		the method used for calculation of distance.
#'		Currently, only the method using the Vincenty's formulae is
#'		implimented.
#'	@param threshold
#'		threshold difference to determine convergence.
#'		The value of 1e-12 produces precision of 0.06mm.
#'	@param maxit
#'		maximum number of iteration to try before convergence.
#'
#'	@section Details:
#'		\url{https://en.wikipedia.org/wiki/Vincenty's_formulae}.
#'
#'	@export
#------------------------------------------------------------------------------
geographic.distance <- function(
	x.name, y.name, ellipsoid = c("grs80", "wgs84", "bessel1841"),
	method = c("vincenty"), threshold = 1e-12, maxit = 10000
) {
	ellipsoid <- match.arg(ellipsoid)
	a <- ELLIPSOIDS[[ellipsoid]]$semi.major.axis.m
	b <- ELLIPSOIDS[[ellipsoid]]$semi.minor.axis.m
	fun <- function(data.train, data.test, na.rm = TRUE) {
		phi1 <- deg2rad(mean(data.train[y.name], na.rm = na.rm))
		phi2 <- deg2rad(mean(data.test[y.name], na.rm = na.rm))
		lon1 <- deg2rad(mean(data.train[x.name], na.rm = na.rm))
		lon2 <- deg2rad(mean(data.test[x.name], na.rm = na.rm))
		d <- vincenty.distance(a, b, lon1, phi1, lon2, phi2, threshold, maxit)
		return(d)
	}
	return(fun)
}

#==============================================================================
#	Functions used for forecast horizon.
#==============================================================================

#------------------------------------------------------------------------------
#'	(Internal) Calculate distance between training and test datasets.
#'
#'	@param fold.index
#'		an integer representing index of the fold for which the distance
#'		between test and training datasets is calculated.
#'	@param data
#'		a data.frame containing explanatory variable(s).
#'	@param cv.group
#'		a vector of integer representing grouping of observation.
#'	@param distance.fun
#'		a function calculating distance between test and training datasets.
#'		It should accept two data.frames in the following form and calculate
#'		distance between them: \code{distance.fun(training.data, test.data)}.
#'		Functions produced by \code{\link{geographic.distance}} and
#'		\code{\link{mess}} can be used.
#------------------------------------------------------------------------------
calculate.distance.between.train.and.test <- function(
	fold.index, data, cv.group, distance.fun
) {
	data.train <- data[cv.group != fold.index, , drop = FALSE]
	data.test <- data[cv.group == fold.index, , drop = FALSE]
	return(distance.fun(data.train, data.test))
}

#------------------------------------------------------------------------------
#' (Experimental) Draw a forecast horizon graph.
#'
#'	Draw a forecast horizon graph using result of the cross validation.
#'	This function is experimental.
#'
#'	@param object
#'		a \code{cv.models} object.
#'	@param metric.name
#'		a character representing name of metrics to be drawn.
#'	@param distance.fun
#'		a function which calculates distance between training and test dataset.
#'		It should accept two data.frames in the following form and calculate
#'		distance between them: \code{distance.fun(training.data, test.data)}.
#'		Functions produced by \code{\link{geographic.distance}} and
#'		\code{\link{mess}} can be used.
#'	@param index
#'		an index of candidate model in the \code{cv.models} object.
#'	@param ylab
#'		label of Y axis.
#'	@param xlab
#'		label of X axis.
#'	@param draw
#'		logical indicating whether the plot is draw.
#'		If FALSE, this function only returns calculated results and draw
#'		nothing.
#'	@param ...
#'		graphical parameters passed to plot function.
#'
#'	@return
#'	a data.frame having distance between training data and corresponding
#'	performance measure.
#'
#'	@export
#------------------------------------------------------------------------------
forecast.horizon <- function(
	object,
	metric.name = ifelse(
		object$adapter$model.type == "regression", "q.squared", "mcc"
	),
	distance.fun = mess(), index = 1, ylab = metric.name,
	xlab = deparse(substitute(distance.fun)), draw = TRUE, ...
) {
	# Extract explanatory variables.
	data <- object$adapter$data[object$adapter$x.names()]
	# Extract index.
	cv.group <- object$cv.results[[index]]$cv.group
	# Extract metric.
	object$aggregate.method = "folds"
	metrics <- cv.metrics(object, list(object$cv.results[[index]]$fits))[[1]]
	# Calculate distance between training and test data.
	distance <- sapply(
		1:object$folds, calculate.distance.between.train.and.test,
		data = data, cv.group = cv.group, distance.fun = distance.fun
	)
	graphics::plot(
		distance, metrics[, metric.name], ylab = ylab, xlab = xlab, ...
	)
	invisible(cbind(data.frame(distance = distance), metrics))
}


################################################################################
# Part of the R/EpiILM package
#
# AUTHORS:
#         Vineetha Warriyar. K. V. <vineethawarriyar.kod@ucalgary.ca>,
#         Waleed Almutiry <wkmtierie@qu.edu.sa>, and
#         Rob Deardon <robert.deardon@ucalgary.ca>
#
# Algorithm based on:
#         Deardon R, Brooks, S. P., Grenfell, B. T., Keeling, M. J., Tildesley,
#         M. J., Savill, N. J., Shaw, D. J.,  Woolhouse, M. E. (2010).
#         Inference for individual level models of infectious diseases in large
#         populations. Statistica Sinica, 20, 239-261.
#
# Free software under the terms of the GNU General Public License, version 2,
# a copy of which is available at http://www.r-project.org/Licenses/.
################################################################################

epidata <- function(type, n, tmin = NULL, tmax, sus.par, trans.par = NULL, beta = NULL, spark = NULL,
                    Sformula = NULL, Tformula = NULL, x = NULL, y = NULL,
                    inftime = NULL, infperiod = NULL, contact = NULL) {

  # Error checks for input arguments
  if (any(is.null(type) | !(type %in% c("SI", "SIR"))) == TRUE) {
       stop("Specify type as \"SI\" or \"SIR\" ", call. = FALSE)
  }

  ns <- length(sus.par)
  if  (!is.null(trans.par)) {

    nt <- length(trans.par)
    flag.trans <- 1
    phi <- trans.par

  } else {

    nt <- 1
    flag.trans <- 0
    phi <- 1

  }

  if (all(is.null(contact) &  (is.null(x) | is.null(y))) == TRUE) {
      stop('epidata: Specify contact network or x, y coordinates')
  }

  if (is.null(contact)) {
    ni <- length(beta)
    if (ni != 1) {
      stop("epidata: The input of beta has more than one value while the considered distance-based ILM needs only one spatial parameter, beta.", call. = FALSE)
    }
    if (!is.null(x)) {
      if (any((length(y) != n) | (length(x) != n)) == TRUE) {
        stop('epidata: Length of x or y is not compatible ')
      }
    }
  } else {
    if (length(contact)/(n * n) == 1) {
      ni <- 1
      if (is.null(beta)) {
        beta <- 1
      } else {
        stop("epidata: As the model has only one contact network, The model does not need a network parameter beta, beta must be assigned to its default values = NULL", call. = FALSE)
      }
    } else if (length(contact)/(n * n) > 1) {
      ni <- length(beta)
      if (length(contact)/(n * n) != ni) {
        stop('epidata: Dimension of beta and the number of contact networks are not matching')
      }
    }
    network <- array(contact, c(n, n, ni))
  }

  if (is.null(tmin)){
    tmin <- 1
  }

  if (is.null(spark)) {
    spark <- 0
  }

  if (!is.null(inftime)) {
      if ((length(inftime) != n)) {
        stop('epidata: Length of inftime is not compatible ')
      }
  } else {
        inftime <- rep(0, n)
  }

  if (all(is.null(infperiod) & type == "SIR") == TRUE) {
    stop(' epidata: Specify removal, infperiod')
  }

  if (!is.null(infperiod)) {
      if (length(infperiod) != n) {
        stop('epidata: Length of infperiod is not compatible')
      }
      if (type == "SI") {
        stop('epidata: Type must be "SIR"')
      }
       remt <- rep(0, n)
  }

  # formula for susceptibility (covariate) function
   if (!is.null(Sformula)) {
     covmat.sus <- model.matrix(Sformula)

     if (all((ncol(covmat.sus) == length(all.vars(Sformula))) & (ns != length(all.vars(Sformula)))) == TRUE) {
       stop('epidata: Check Sformula (no intercept term) and the dimension of sus.par')
     }

     if (all((ncol(covmat.sus) > length(all.vars(Sformula))) & (ns != ncol(covmat.sus))) == TRUE) {
       stop('epidata: Check Sformula (intercept term) and the dimension of sus.par')
     }
   } else {
       if (ns == 1) {
         covmat.sus <- matrix(1.0, nrow = n, ncol = ns)
       }
       if (ns > 1) {
         stop('epidata: Please specify the susceptibility covariate')
       }
   }

   # formula for transmissibility (covariate) function
   if (flag.trans == 1) {
     if (is.null(Tformula)) {
       stop("epidata: Tformula is missing. It has to be specified with no intercept term and number of columns equal to the length of trans.par", call. = FALSE)
     } else if (!is.null(Tformula)) {
   		covmat.trans <- model.matrix(Tformula)

   		if (all((ncol(covmat.trans) == length(all.vars(Tformula))) & (nt != length(all.vars(Tformula)))) == TRUE) {
   			stop("epidata: Check Tformula. It has to be with no intercept term and number of columns equal to the length of trans.par", call. = FALSE)
   		}
    }
   } else if (flag.trans == 0) {
   	covmat.trans <- matrix(1.0, nrow = n, ncol = nt)
   }

 # Calling fortran subroutine - Purely Spatial: Susceptible-Infectious(SI)
  if (all((type == "SI") & is.null(contact)) == TRUE) {
    tmp <- .Fortran("dataxy",
                    x = as.vector(x, mode = "double"),
                    y = as.vector(y, mode = "double"),
                     n = as.integer(n),
                     tmin = as.integer(tmin),
                     tmax = as.integer(tmax),
                     ns = as.integer(ns),
                     nt = as.integer(nt),
                     ni = as.integer(ni),
                     alpha = as.vector(sus.par, mode = "double"),
                     phi = as.vector(phi, mode = "double"),
                     beta =as.vector(beta, mode = "double"),
                     spark = as.numeric(spark),
                     covmatsus = matrix(as.double(covmat.sus), ncol = ncol(covmat.sus), nrow = n),
                     covmattrans = matrix(as.double(covmat.trans), ncol = ncol(covmat.trans), nrow = n),
                     tau = as.vector(inftime, mode = "integer")
                     )

    result1 <- list(type = type, XYcoordinates = cbind(x, y), contact = NULL, inftime = tmp$tau)
  }

 # Calling fortran subroutine - Purely Spatial: Susceptible-Infectious-Removed (SIR)
  if (all((type == "SIR") & is.null(contact)) == TRUE) {
    tmp <- .Fortran("dataxysir",
                     n = as.integer(n),
                     tmin = as.integer(tmin),
                     tmax = as.integer(tmax),
                     ns = as.integer(ns),
                     nt = as.integer(nt),
                     ni = as.integer(ni),
                     alpha = as.vector(sus.par, mode = "double"),
                     phi = as.vector(phi, mode = "double"),
                     beta =as.vector(beta, mode = "double"),
                     spark = as.numeric(spark),
                     covmatsus = matrix(as.double(covmat.sus), ncol = ncol(covmat.sus), nrow = n),
                     covmattrans = matrix(as.double(covmat.trans), ncol = ncol(covmat.trans), nrow = n),
                     lambda = as.vector(infperiod, mode = "integer"),
                     x = as.vector(x, mode = "double"),
                     y = as.vector(y, mode = "double"),
                     tau = as.vector(inftime, mode = "integer"),
                     remt = as.vector(remt, mode = "integer")
                     )

    result1 <- list(type = type, XYcoordinates = cbind(x, y), contact = NULL, inftime = tmp$tau, remtime = tmp$remt)
  }

  # Calling fortran subroutine - Contact networks: Susceptible-Infectious (SI)
  if (all((type == "SI") & !is.null(contact)) == TRUE) {
    tmp <- .Fortran("datacon",
                     n = as.integer(n),
                     tmin = as.integer(tmin),
                     tmax = as.integer(tmax),
                     ns = as.integer(ns),
                     nt = as.integer(nt),
                     ni = as.integer(ni),
                     alpha = as.numeric(sus.par),
                     phi = as.numeric(phi),
                     beta = as.numeric(beta),
                     spark = as.numeric(spark),
                     covmatsus = matrix(as.double(covmat.sus), ncol = ncol(covmat.sus), nrow = n),
                     covmattrans = matrix(as.double(covmat.trans), ncol = ncol(covmat.trans), nrow = n),
                     network = as.vector(network),
                     tau = as.integer(inftime)
                     )

    result1 <- list(type = type, XYcoordinates = cbind(x, y), contact = contact, inftime = tmp$tau)
  } else if (all((type == "SIR") & !is.null(contact)) == TRUE) {
 # Calling fortran subroutine - Contact networks: Susceptible-Infectious-Removed (SIR)
    tmp <- .Fortran("dataconsir",
                     n = as.integer(n),
                     tmin = as.integer(tmin),
                     tmax = as.integer(tmax),
                     ns = as.integer(ns),
                     nt = as.integer(nt),
                     ni = as.integer(ni),
                     lambda = as.integer(infperiod),
                     alpha = as.numeric(sus.par),
                     phi = as.numeric(phi),
                     beta = as.numeric(beta),
                     spark = as.numeric(spark),
                     covmatsus = matrix(as.double(covmat.sus), ncol = ncol(covmat.sus), nrow = n),
                     covmattrans = matrix(as.double(covmat.trans), ncol = ncol(covmat.trans), nrow = n),
                     network = as.vector(network),
                     tau = as.integer(inftime),
                     remt = as.integer(remt)
                     )

    result1 <- list(type = type, XYcoordinates = cbind(x, y), contact = contact, inftime = tmp$tau, remtime = tmp$remt)
  }
  class(result1) <- "epidata"

  result1
  # End of function
}


# Generate synthetic datasets
#
# author: Alberto Lumbreras
##################################
library(MASS)
library(ggplot2)
library(GGally)
library(gridExtra)
library(gridGraphics)
cov <-  matrix(c(0.01,0.001,
                 0.001,0.01), ncol=2, nrow=2)

clear <- function(U=100, R=5){
  F <- 2
  # Assign roles uniformly
  z <- sort(rep(1:R, length=U))

  # Assign features
  A <- matrix(1, F, U)
  for(r in 1:R){
    x = cos(2*pi*r/R)
    y = sin(2*pi*r/R)
    cat(x,y,"\n")
    A[,z==r] <- t(mvrnorm(n=sum(z==r), mu=c(x,y), Sigma=cov))
  }

  # Assign behavior coefficients
  #mu_br <- seq(-200,200, length.out=R) #works ok
  mu_br <- seq(0,200, length.out=R)
  b <- rep(0, U)
  for(r in 1:R){
   b[z==r]<- rnorm(sum(z==r), mean=mu_br[r], sd=8)
  }

  list(A=A,
       b=b,
       z=z)
}

agreement <- function(U=100, R=10){
  F <- 2
  # Assign roles uniformly
  z <- sort(rep(1:R, length=U))

  # Assign features
  A <- matrix(1, F, U)
  for(r in 1:R){
    x = 0.45*cos(2*pi*r/R)
    y = 0.45*sin(2*pi*r/R)
    cat(x,y,"\n")
    A[,z==r] <- t(mvrnorm(n=sum(z==r), mu=c(x,y), Sigma=cov))
  }

  # Assign behavior coefficients
  mu_br <- seq(0,100, length.out=R)
  b <- rep(0, U)
  for(r in 1:R){
    b[z==r]<- rnorm(sum(z==r), mean=mu_br[r], sd=5)
  }

  list(A=A,
       b=b,
       z=z)
}

disagreement <- function(U=100, R=10){
  F <- 2

  # Assign roles uniformly
  z <- sort(rep(1:R, length=U))

  # Assign features
  A <- matrix(1, F, U)
  for(r in 1:(R-2)){
    x = 0.5*cos(2*pi*r/R)
    y = 0.5*sin(2*pi*r/R)
    cat(x,y,"\n")
    A[,z==r] <- t(mvrnorm(n=sum(z==r), mu=c(x,y), Sigma=cov))
  }

  for(r in (R-1):R){
    x = 0
    y = 0
    cat(x,y,"\n")
    A[,z==r] <- t(mvrnorm(n=sum(z==r), mu=c(x,y), Sigma=cov))
  }

  # Assign behavior coefficients
  mu_br <- seq(0,100, length.out=R)
  b <- rep(0, U)
  for(r in 1:R){
    b[z==r]<- rnorm(sum(z==r), mean=mu_br[r], sd=5)
  }

  list(A=A,
       b=b,
       z=z)
}

real <- function(){
  data(iris)
  idx <- sample(1:150, 50) # subselect 50 so that feature views does not dominate the inference
  iris <- iris[idx,]
  idx <- as.numeric(row.names(iris))
  iris <- iris[order(idx),]
  z <- as.numeric(iris$Species)
  U <- nrow(iris)
  A <- matrix(1, 3, U)

  # real 1
  A[1,] <- iris$Sepal.Width
  A[2,] <- iris$Petal.Length
  A[3,] <- iris$Petal.Width
  rownames(A) <- c("Sepal.Width", "Petal.Length", "Petal.Width")

  # too overlapped
  #b <- iris$Sepal.Length
  #b <- 100*(b-min(b))/(max(b)-min(b)) # to a 0,100 range

  # Assign behavior coefficients
  mu_br <- seq(0,100, length.out=3)
  b <- rep(0, U)
  for(r in 1:3){
    b[z==r]<- rnorm(sum(z==r), mean=mu_br[r], sd=5)
  }

  list(A=A,
       b=b,
       z=z)
}

#############################################
# Generate participations and thread lengths
#############################################
# from this single dataset we will extract a subset of users and threads according to the scenario.
participations <- function(b=c(1,2,3,4,5), b0=0, s_y=1/5, T=10){
  # Warning: in Iris, b is much smaller and therefore s_y should be greater
  U <- length(b)

  # Participations matrix
  P <- matrix(sample(c(0,1), U*T, replace=TRUE, prob=c(0.5,0.5)), nrow=U, ncol=T)
  P <- apply(P,2, function(x){x/sum(x)}) # normalize so that noise s_y has the same effect in every thread
  P <- P[, colSums(is.na(P)) != nrow(P)] # drop empty threads

  # Length of threads
  T <- dim(P)[2]
  P_ <- rbind(rep(1,T), P)
  b_ <- c(b0,b)

  means <- t(P_)%*%b_
  cat("\ns_y*",s_y, sqrt(1/s_y))
  y <- sapply(1:T, function(i) {rnorm(1, mean=means[i], sd=sqrt(1/s_y))})

  list(P=P,
       y=y)
}

##########################################################
##########################################################
save.data <- function(A, b, z){
  # Save dataset to files
  U <- dim(A)[2]
  df <- data.frame(matrix(NA, U, 4))
  names(df) <- c("z", "f1", "f2", "b")
  df$z <- z-1 # start from 0
  df$b <- b
  df$f1 <- A[1,]
  df$f2 <- A[2,]
  write.table(df, file=paste0("data_users_", U, ".csv"), sep= "\t", row.names = FALSE)
}

load.data <- function(filepath){
  df <- read.table(filepath, sep='\t', header=TRUE)
  df
}

save.real.data <- function(A, b, z){
  # Save dataset to files
  U <- dim(A)[2]
  df <- data.frame(matrix(NA, U, 5))
  names(df) <- c("z", "f1", "f2", "f3", "b")
  df$z <- z-1 # start from 0
  df$b <- b
  df$f1 <- A[1,]
  df$f2 <- A[2,]
  df$f3 <- A[3,]
  write.table(df, file=paste0("data_users_", U, ".csv"), sep= "\t", row.names = FALSE)
}

save.participations <- function(P, y, suffix="train"){
  # Save participation matrix and thread lengths
  # one big participations file for every scenario and every U
  U <- dim(P)[1]
  write.table(as.data.frame(P), file=paste0(suffix, "_participations_", U, ".csv"), sep= "\t", row.names = FALSE)
  write.table(as.data.frame(y), file=paste0(suffix, "_lengths_", U, ".csv"), sep= "\t", row.names = FALSE)
}

plot.data <- function(A, b, z){
  df <- data.frame(A1=A[1,], A2 = A[2,], b=b, z=z)
  p1 <- ggplot(df, aes(x=A1,y=A2)) +
        geom_point(size=2, aes(colour = factor(z), shape= factor(z))) +
        xlab('feature 1') +
        ylab('feature 2') +
        theme(text = element_text(size = 13),
              panel.background = element_blank(),
              panel.grid.major = element_blank(),
              panel.grid.minor = element_blank(),
              aspect.ratio=1,
              axis.line = element_line(colour = "black"),
              legend.key = element_rect(fill = "white"),
              legend.position="none")

  p2 <- ggplot(df, aes(x=1:length(b), y=b)) +
          geom_point(size=2, aes(colour = factor(z), shape= factor(z))) +
          xlab('users') +
          ylab('b') +
          theme(text = element_text(size = 13),
              panel.background = element_blank(),
              panel.grid.major = element_blank(),
              panel.grid.minor = element_blank(),
              aspect.ratio=1,
              axis.line = element_line(colour = "black"),
              legend.key = element_rect(fill = "white"),
              legend.position="none")

  #grid.arrange(p1, p2, ncol=2)
  #g <- arrangeGrob(p1, p2, ncol=2)
  g <- plot_grid(p1, p2, ncol = 2,
                 align = 'v') # aligning does not work here
  g
}

plot.real.data <- function(A, b, z){

  A.df <- as.data.frame(cbind(t(A), z))
  A.df$z <- as.factor(A.df$z)
  theme_set(theme_bw())
  p1 <- ggpairs(A.df, columns= 1:3,
          upper = list(continuous = "points"),
          lower = list(continuous = "points"),
          diag = list(continuous = "densityDiag"),
          ggplot2::aes(color = z))+
    theme(panel.grid.major = element_blank(),
          panel.grid.minor = element_blank(),
          aspect.ratio=1)

  df <- data.frame(A1=A[1,], A2 = A[2,], b=b, z=z)
  p2 <- ggplot(df, aes(x=1:length(b), y=b)) +
    geom_point(aes(colour = factor(z))) +
    xlab('users') +
    ylab('b') +
    theme(text = element_text(size = 13),
          panel.background = element_blank(),
          panel.grid.major = element_blank(),
          panel.grid.minor = element_blank(),
          aspect.ratio=1,
          axis.line = element_line(colour = "black"),
          legend.key = element_rect(fill = "white"),
          legend.position="none")

  print(p1)
  g <- grid.grab()
  grid.arrange(g, p2, widths=c(0.5,0.5))

  g <- plot_grid(p1, p2, ncol = 2,
                 align = 'v') # aligning does not work here
  g
  ########################################
  ########################################
  # Simple alternative
  #174 mm x 70 mm = 6.85 x 2.75
  setEPS()
  postscript("../doc/ComputStat submission/Fig7_data_iris_features_bw.eps")#,
             #width = 6.85/2, height = 2.75)
  pairs(A.df[,c(1,2,3)], col=z+1, pch=z+1, cex.lab=2, cex.axis=2)
  dev.off()

  par(pty='s')
  setEPS()
  postscript("../doc/ComputStat submission/Fig7_data_iris_behaviors_bw.eps")#,
             #width = 6.85/2, height = 2.75)
  par(mar=c(5,5,4,1)+.1)
  plot(1:length(b), b, col=z+1, pch=z+1, xlab="users", ylab="b", cex.lab=2, cex.axis=1.5)
  dev.off()
}

##########################################################
# Main
##########################################################
if (FALSE){
  generators <- c(clear, disagreement, agreement)
  gen <- generators[[2]] # chose one of the three scenarios

  # Generate and plot the data
  i = 50 # number of users
  # user features and behaviors
  data <- gen(U=i, R=5)
  g<- plot.data(data$A, data$b, data$z)
  save.data(data$A, data$b, data$z)

  # user participations and thread lengths
  # (a big synthetic forum of U users)
  # make T big enough so that training in different experiments get different training instances
  parts <- participations(b=data$b, T=10000)
  save.participations(parts$P,parts$y, suffix="train")

  # test set
  parts <- participations(b=data$b, T=1000)
  save.participations(parts$P,parts$y, suffix="test")
}

if (FALSE){
  # Generate a dataset that reproduces the Iris dataset structure
  # s_y adapted to the size of b so that the noise is reasonable
  data <- real()
  plot.real.data(data$A, data$b, data$z)
  save.real.data(data$A, data$b, data$z)

  # user participations and thread lengths
  #parts <- participations(b=data$b, T=1000, s_y=1000)
  parts <- participations(b=data$b, T=10000)
  save.participations(parts$P,parts$y, suffix="train")

  # test set
  #parts <- participations(b=data$b, T=100, s_y=1000)
  parts <- participations(b=data$b, T=1000)
  save.participations(parts$P,parts$y, suffix="test")

  # sanity checks
  ###############################################"
  par(mfrow=c(3,1))
  b <- data$b
  P <- parts$P
  y <- parts$y
  U <- dim(P)[1]
  alphaI <- diag(U)*0.01

  T <- dim(P)[2]
  P_ <- rbind(rep(1,T), P)

  # plot lengths with b and no noise
  b_ <- c(0,b)
  y_ideal <- t(P_)%*%b_
  idx <- order(y_ideal) # take these lengths idx as reference
  plot(y_ideal[idx])
  title("noise free")
  #plot(b)

  # plot the generated lengths
  plot(y[idx])
  title("with noise (real data)")

  # what predictiorepeat with mle
  b_mle <- (solve(P%*%t(P)+alphaI)%*%P)%*%y
  b_ <- c(0,b_mle)
  y_mle <- t(P_)%*%b_
  plot(y_mle[idx])
  title("reproduce with estimated coefficients")
}

# Plot saved user data
if(FALSE){
  df <- load.data("./agreement/data_users_50.csv")
  g <- plot.data(t(df[,c(2,3)]), df$b, df$z)
  ggsave("../doc/ComputStat submission/Fig2_data_agreement_bw.eps",
         device="eps",
         plot=g,
         width = 174, height = 70, units = "mm")
  print(g)

  df <- load.data("./iris/data_users_50.csv")
  A <- t(df[,c(2,3,4)])
  b <- df$b
  z <- df$z
  g <- plot.real.data(t(df[,c(2,3,4)]), df$b, df$z)
  ggsave("../doc/ComputStat submission/Fig7_data_iris_bw.eps",
         device="eps",
         plot=g,
         width = 174, height = 70, units = "mm")

}


g <- read.csv(
  file = '/home/max/Documents/github/Fun/AI/coursera/PublicHeatlh/w2_r_scripts/dataset.csv',
  header = TRUE,
  sep = ','
)

g$fruit_veg = g$fruit + g$veg

# Display default histograms

hist(
  g$fruit_veg,
  main = "Daily consumption of combined fruit + vegetables",
  xlab = "Number of portions",
  axes = 'F'
)
axis(side = 1, at = seq(0, 15, 1))
axis(side = 2, at = seq(0, 20, 2))

# Display ggplot histograms
require(ggplot2)

ggplot() +
  geom_histogram(data = g, aes(x = fruit_veg), binwidth = 0.5, fill = 'grey', col = 'black') +  # bins=20,
  labs(x = "Number of portions", y = "Frequency") +
  scale_x_continuous(breaks = seq(from = 0, to = 15, by = 1))


getSimsTable <- function(x, ...){
    require(dplyr)
    nChains <- dim(x)[2]
    nPost <- dim(x)[1]
    x %>%
        as.data.frame(...) %>%
            mutate(chain = rep(1:nChains, ea = nPost),
                   iteration = rep(1:nPost, nChains))
}

mcmcHistory <- function(fit, pars = names(fit), nParPerPage = 6){
    require(dplyr)
    require(tidyr)
    require(ggplot2)
    simsTable <- getSimsTable(fit, pars = pars)
    posterior <- simsTable %>%
      gather(key = parameter, value = value, -chain, -iteration)

    # gather(key = parameter, value = value, -simsTable$chain, -simsTable$iteration)

    parameters <- sort(unique(posterior$parameter))
    nParameters <- length(parameters)
    nPages <- ceiling(nParameters / nParPerPage)
    parameters <- data.frame(parameter = parameters,
                             page = sort(rep(1:nPages, length = nParameters)),
                             stringsAsFactors = FALSE)
    posterior <- posterior %>% left_join(parameters)
    posterior$chain <- as.factor(posterior$chain)

    for(i in 1:nPages){
        xplot <- subset(posterior, page == i)
        p1 <- ggplot(xplot, aes(x = iteration, y = value))
        print(p1 + aes(color = chain) + geom_line() +
                  labs(x = "iteration", y = "value") +
                      theme(text = element_text(size = 12), axis.text = element_text(size = 12),
                            legend.position = "none", strip.text = element_text(size = 8)) +
                                facet_wrap(~ parameter, ncol = 1, scales = "free_y"))
    }
    NULL
}

mcmcDensity <- function(fit, pars = names(fit), byChain = FALSE, nParPerPage = 16, prior = NULL){
    require(dplyr)
    require(tidyr)
    require(ggplot2)
    simsTable <- getSimsTable(fit, pars = pars)
    posterior <- simsTable %>%
      gather(key = parameter, value = value, -chain, -iteration)
    simsTable <- getSimsTable(fit, pars = pars)

    parameters <- sort(unique(posterior$parameter))
    nParameters <- length(parameters)
    nPages <- ceiling(nParameters / nParPerPage)
    parameters <- data.frame(parameter = parameters,
                             page = sort(rep(1:nPages, length = nParameters)),
                             stringsAsFactors = FALSE)
    posterior <- posterior %>% left_join(parameters)
    posterior$chain <- as.factor(posterior$chain)

    if(!is.null(prior)) prior <- prior %>% left_join(parameters)

    for(i in 1:nPages){
        xplot <- subset(posterior, page == i)
        p1 <- ggplot(xplot, aes(x = value))
        if(byChain) p1 <- p1 + aes(color = chain)
        p1 <- p1 + geom_density() +
                  labs(x = "value", y = "density") +
                      theme(text = element_text(size = 12), axis.text = element_text(size = 8),
                            legend.position = "none", strip.text = element_text(size = 8)) +
                                facet_wrap(~ parameter, ncol = 4, nrow = 4, scales = "free")
        if(!is.null(prior))
            p1 <- p1 + geom_line(data = subset(prior, page == i), aes(x = value, y = density),
                                 color = "red")
        print(p1)
    }
    NULL
}

summary.mcmc.list <- function (object, quantiles = c(0.025, 0.25, 0.5, 0.75, 0.975),
    ...)
{
    x <- mcmc.list(object)
    statnames <- c("Mean", "SD", "Naive SE", "Time-series SE")
    varstats <- matrix(nrow = nvar(x), ncol = length(statnames),
        dimnames = list(varnames(x), statnames))
    xtsvar <- matrix(nrow = nchain(x), ncol = nvar(x))
    if (is.matrix(x[[1]])) {
        for (i in 1:nchain(x)) for (j in 1:nvar(x)) xtsvar[i,
            j] <- coda:::safespec0(x[[i]][, j])
        xlong <- do.call("rbind", x)
    }
    else {
        for (i in 1:nchain(x)) xtsvar[i, ] <- coda:::safespec0(x[[i]])
        xlong <- as.matrix(x)
    }
    xmean <- apply(xlong, 2, mean, na.rm = TRUE)
    xvar <- apply(xlong, 2, var, na.rm = TRUE)
    xtsvar <- apply(xtsvar, 2, mean, na.rm = TRUE)
    varquant <- t(apply(xlong, 2, quantile, quantiles, na.rm = TRUE))
    varstats[, 1] <- xmean
    varstats[, 2] <- sqrt(xvar)
    varstats[, 3] <- sqrt(xvar/(niter(x) * nchain(x)))
    varstats[, 4] <- sqrt(xtsvar/(niter(x) * nchain(x)))
    varquant <- drop(varquant)
    varstats <- drop(varstats)
    out <- list(statistics = varstats, quantiles = varquant,
        start = start(x), end = end(x), thin = thin(x), nchain = nchain(x))
    class(out) <- "summary.mcmc"
    return(out)
}

parameterTable <- function(fit, pars = names(fit)){
    rstan:::monitor(as.array(fit, pars = pars), warmup = 0, print = FALSE)
}

colVars <- function(a) {
    vars <- a[1,]
    for (n in 1:ncol(a))
        vars[n] <- var(a[,n])
    return(vars)
}

get_mass_matrix <- function(stanfit, nChains) {
  adapt_info <- get_adaptation_info(stanfit)
  string <- "# Step size = 0.00654987\n# Diagonal elements of inverse mass matrix:\n#"
  start <- nchar(string) + 1

  mass_matrix <- list()
  for (i in 1:nChains) {
    end <- nchar(adapt_info[i]) - nchar("\n# ")
    mass_matrix_chain <- substring(adapt_info[i], start, end)
    mass_matrix[[i]] <-
      as.numeric(strsplit(mass_matrix_chain, split =", ")[[1]])
  }
  mass_matrix
}


data(diamonds, package = "ggplot2")
class(diamonds)
library(dplyr)
dia <- as.tbl(diamonds)
dia

#filtering
dia[,c('carat', 'price')]
dia %>% select(carat, price)
dia %>% select(1,7)
dia %>% select(-c(1,7))

dia %>% filter(cut == "Ideal")
dia %>% filter(cut == "Ideal", color == "E")
dia %>% filter(cut == "Ideal" & color == "E")
dia %>% filter(cut == "Ideal" | color == "E") #or
dia %>% filter(cut %in% c('Ideal','Premium'))

#slicing
dia %>% slice(1:5)
dia %>% slice(c(1,3,5:10))

#mutate or change columns
dia %>% mutate(ratio=price/carat)
dia

library(magrittr)
dia %<>% mutate(ratio=price/carat)
dia

#summarize
dia %>% summarize(mean(price))
dia %>% summarize(AvgPrice=mean(price))

#group by
dia %>% group_by(cut) %>% summarize(AvgPrice=mean(price))
dia %>% group_by(cut, color) %>% summarize(AvgPrice=mean(price))
dia %>% group_by(cut) %>% summarize(AvgPrice=mean(price), AvgCarat=mean(carat), TotalCarat=sum(carat))


# Usa <- para atribuição de valores
x <- 0:6

# Class para saber a classe de um ojbeto/variavel
class(x)

# As para coerção (conversão) de objetos
as.numeric(x)
as.double(x)
as.array(x)
as.character(x)

# c() - para criação de vetores de acordo com os argumentos passados
y <- c(1,34)

m <- 1:10

# dim retorna e atribui uma dimensao ao objeto
dim(m)
dim(m) <- c(2,5)

x <- 1:4
y <- 10:12

# Junção de vetores (colunas ou linhas)
z <- cbind(x,y)
rbind(x,y)

# List para criar listas que possuem objetos de qualquer classe
x1 <- list(1, "a", c("1", TRUE), 1 + 4i, c(1:5))

# is para verificar se um objeto é determinado tipo/classe
is.na(x)
is.nan(x)

# data.frame
x <- data.frame(foo=1:4, bar = c(T,T,F,F))

# Retorna ou atribui nome as colunas
x <- 1:3
names(x)
names(x) <- c("foo", "bar", "norf")
names(x)

x <- list(a=10,b=25,c=39)
names(x)

dimnames(x)

m <- matrix(1:4, nrow=2, ncol=2, TRUE, dimnames = list(c("x", "y"), c("c","d")))
#dimnames(m) <- list(c("a", "b"), c("c","d"))
m

x <- Sys.time()

unclass(x)

x <- Sys.time()
p <- as.POSIXlt(x)
unclass(p)
names(unclass(p))

datestring <- c("Jan 10, 2012 10:40", "Dec 9, 2011 9:10")datestring
strptime(datestring[1], "%B %d, %Y %H:M")

x <- as.Date("2012-03-01")
y <- as.Date("2012-02-28")

x-y

x <- as.POSIXct("2012-10-25 01:00:00")
y <- as.POSIXct("2012-10-25 06:00:00")
y-x


### INPUT PROCESSING ###
# Read csv data
read.data <- function (filename, ...)
{
	tab <- read.table(filename, sep=",", header=FALSE, ...)
	if (ncol(tab) == 2)
		colnames(tab) <- c("user", "movie")
	else
		colnames(tab) <- c("user", "movie", "stars")

	class(tab) <- c("data", "data.frame")
	tab
}

# Reduce user and movie domain
reduce.data <- function (df, ui = sort(union(df$user, NULL)), mi = sort(union(df$movie, NULL)))
{
	df$user <- sapply(df$user, function(x) {which(ui==x)})
	df$movie <- sapply(df$movie, function(x) {which(mi==x)})
	list(data=df,ui=ui,mi=mi)
}

expand.data <- function (reduced, ui, mi)
{
	data.frame(user=ui[reduced$user], movie=mi[reduced$movie], reduced[-(1:2)])
}

# Plot in rainbow colors
plot.data <- function(df, rg=c(1,5), col=3, ...)
{
	plot.default(df[c(1,2)], pch=".",
				 col = hsv(h=(df[[col]]-rg[1])/(rg[2]-rg[1])), ...)
}

# Create data matrix
matrix.data <- function (df, init=NA)
{
	mat <- matrix(init, max(df[[1]]), max(df[[2]]))
	mat[(df$movie-1)*nrow(mat)+df$user] <- df$stars
	mat
}

### EVALUATION & OUTPUT ###
# Evaluate matrix on test data set
eval <- function(df, mat)
{
	df <- cbind(df, est=NA)
	df$est <- mat[(df$movie-1)*nrow(mat)+df$user]; df
}

# Write to result file
write.data <- function(df.test, filename, ...)
	write.table(df.test, filename, sep=",", col.names=FALSE, row.names=FALSE, ...)

# Compute error (& analyze it)
error.data <- function(df.test)
{
	list(error = sqrt(mean((df.test$stars - df.test$est)^2)),
		lm = lm(est ~ stars, data=df.test)$coefficients)
}

# Cross evaluation
crosseval <- function(df, m, alg, params)
{
	len <- nrow(df); df <- cbind(df, est=NA)
	perm <- sample(len)		# permute randomly to gain fair results
	for (i in 1:m) {
		# select test data
		ind <- perm[ceiling((i-1)*len/m):floor(i*len/m)]
		# learn
		mat <- alg(df[-ind,], params)
		# estimate on test data
		df$est[ind] <- mat[(df$movie[ind]-1)*nrow(mat) + df$user[ind]]
	}

	# return cross evaluated data set
	return(df)
}

# Cross-evaluation error depending on a parameter
error.plot <- function(df, cvm, alg, params, target)
{
	function(x) {
		params[[target]] <- x
		res <- crosseval(df, cvm, alg, params)
		error.data(res)$error
	}
}

# "Bisection" for parameter tuning
bisect <- function(df, cvm, alg, params, target, rg, numit=20, int=FALSE)
{
	gen.bisect(
		function(x) {
				params[[target]] <- ifelse(int, round(x), x)
				print(params)
				res <- crosseval(df, cvm, alg, params)
				error <- error.data(res)
				print(error);	error$error
			},
		rg[1], rg[2], numit)
}

# Find the minimum of a convex (not necessarily diff'able) function, assuming
# the given interval contains it
gen.bisect <- function(fun, left, right, numit)
{
	middle <- runif(1, left, right)
	fmiddle <- fun(middle)

	for (i in 1:numit) {
		new <- runif(1, left, right)
		fnew <- fun(new)
		if (new < middle) {			# "new" left of "middle"
			if (fnew < fmiddle) {
				right <- middle
				middle <- new
				fmiddle <- fnew
			}
			else {left <- new}
		}
		else {						# "new" right of "middle"
			if (fnew < fmiddle) {
				left <- middle
				middle <- new
				fmiddle <- fnew
			}
			else {right <- new}
		}
	}

	return(middle);
}

### META-ROUTINES ###
read.all <- function(trainfile, qualfile)
{
	train <- read.data(trainfile)
	newtrain <- reduce.data(train)
	qual <- read.data(qualfile)
	newqual <- reduce.data(qual, newtrain$ui, newtrain$mi)
	list(train=newtrain$data, qual=newqual$data, ui=newtrain$ui, mi=newtrain$mi)
}

write.res <- function(all, mat, resfile)
{
	qual <- eval(all$qual, mat)
	qual <- expand.data(qual, all$ui, all$mi)
	write.data(qual, resfile)
}


"
Исследовать и сформулировать отличия в работе функций
определяющих тип вектора: typeof(), mode(), str()
"
w <- c(3,4,4,5)
typeof(w) #Отображение типа объекта
mode(w) #Отображение режима хранения объекта
str(w) #Отображение структуры объекта R


#' Generate Simulation Data
#'
#' @param Ntargets An integer giving the number of targets per miRNA
#' @param Nvar.percent A numeric value giving the percentage of targets to be variable between groups
#' @param Nsample An integer indicating the number of samples per group
#' @return A list containing simulated data
#'
#' @importFrom lqmm make.positive.definite
#' @importFrom MASS mvrnorm
#' @importFrom kSamples ad.test
Generate_simulation <- function(Ntargets, Nvar.percent, Nsample) {
	set.seed(1)
	#
	# Target matrices for three groups
	# --------------------------------------------------------------------------
	gene <- paste("gene_", seq(1000), sep="")
	mir <- paste("miR_", seq(20), sep="")

	# Assign genes to targets by miRNAs <- predicted targets
	# Randomly splitted the genes into n groups where n=length(mir)
	predict.target <- list()
	for (i in mir) {
		predict.target[[i]] <- sample(gene, Ntargets, replace=TRUE)
		# gene <- setdiff(gene, unlist(predict.target))
	}
	# predict.target[[i]] <- gene
	names(predict.target) <- mir

	# Reset
	gene <- paste("gene_", seq(1000), sep="")

	# Now subset to three groups
	# First five miRNAs will have different targets per group
	# Last five will have the same predicted targets
	target.A <- target.B <- target.C <- list()
	for (i in mir) {
		if (which(mir == i) <= 10) {
			target.A[[i]] <- sample(predict.target[[i]], round(Ntargets * (Nvar.percent / 100)))
			target.B[[i]] <- sample(predict.target[[i]], round(Ntargets * (Nvar.percent / 100)))
			target.C[[i]] <- sample(predict.target[[i]], round(Ntargets * (Nvar.percent / 100)))
		} else {
			target.A[[i]] <- target.B[[i]] <- target.C[[i]] <- predict.target[[i]]
		}
		# print(i)
	}

	#
	# Correlation matrices
	# Group-specific targets have stronger regulation
	# --------------------------------------------------------------------------
	all.names <- c(gene, mir)
	adj.A <- matrix(0, nrow=length(all.names), ncol=length(all.names), dimnames=list(all.names, all.names))
	adj.B <- matrix(0, nrow=length(all.names), ncol=length(all.names), dimnames=list(all.names, all.names))
	adj.C <- matrix(0, nrow=length(all.names), ncol=length(all.names), dimnames=list(all.names, all.names))

	for (i in mir) {
			adj.A[predict.target[[i]], i] <- rnorm(length(predict.target[[i]]), mean=-0.2, sd=0.3)
			adj.B[predict.target[[i]], i] <- rnorm(length(predict.target[[i]]), mean=-0.2, sd=0.3)
			adj.C[predict.target[[i]], i] <- rnorm(length(predict.target[[i]]), mean=-0.2, sd=0.3)
		if (which(mir == i) <= 10) {
			beta2 <- sample(1:15, 3)
			beta.a <- rbeta(length(target.A[[i]]), 20, beta2[1])
			adj.A[target.A[[i]], i] <- -0.2 + beta.a * (min(adj.A[,i]) + 0.2)
			beta.b <- rbeta(length(target.B[[i]]), 20, beta2[2])
			adj.B[target.B[[i]], i] <- -0.2 + beta.b * (min(adj.B[,i]) + 0.2)
		}
		# print(i)
	}

	#
	# Turn to expression matrix
	# --------------------------------------------------------------------------
	diag(adj.A) <- 1
	diag(adj.B) <- 1
	diag(adj.C) <- 1
	adj.A[lower.tri(adj.A)] = t(adj.A)[lower.tri(adj.A)]
	adj.B[lower.tri(adj.B)] = t(adj.B)[lower.tri(adj.B)]
	adj.C[lower.tri(adj.C)] = t(adj.C)[lower.tri(adj.C)]

	adj.A.pd <- make.positive.definite(adj.A)
	adj.B.pd <- make.positive.definite(adj.B)
	adj.C.pd <- make.positive.definite(adj.C)

	# Generate multivariate guassian networks
	expr.A <- t(mvrnorm(Nsample, mu=rep(0, length(all.names)), Sigma=adj.A.pd))
	expr.B <- t(mvrnorm(Nsample, mu=rep(0, length(all.names)), Sigma=adj.B.pd))
	expr.C <- t(mvrnorm(Nsample, mu=rep(0, length(all.names)), Sigma=adj.C.pd))

	colnames(expr.A) <- paste("Sample_A", seq(Nsample), sep="")
	colnames(expr.B) <- paste("Sample_B", seq(Nsample), sep="")
	colnames(expr.C) <- paste("Sample_C", seq(Nsample), sep="")

	mrna.mat <- cbind(expr.A[gene, ], expr.B[gene, ], expr.C[gene, ])
	mirna.mat <- cbind(expr.A[mir, ], expr.B[mir, ], expr.C[mir, ])

	#
	# Output Results
	# --------------------------------------------------------------------------
	group.label <- as.factor(rep(c("A", "B", "C"), each=Nsample))
	names(group.label) <- colnames(mrna.mat)

	target.mat <- matrix(0, nrow=nrow(mrna.mat), ncol=nrow(mirna.mat), dimnames=list(row.names(mrna.mat), row.names(mirna.mat)))
	for (i in names(predict.target)) {
		target.mat[predict.target[[i]], i] <- 1
	}

	sim.data <- list(target.mat = target.mat,
					group.label = group.label,
					mrna.mat = mrna.mat,
					mirna.mat = mirna.mat)

	return(sim.data)
}

# Example
# sim.data <- Generate_simulation(Ntargets=70, Nvar.percent=75, Nsample=100)


library(plyr)

h1 <- read.csv("C:/data2/voluntary_6_h2.similarity_length.txt")

h1$rawscore <- 1 - h1$similarity
h1$length <- as.double(h1$length)

length2 <- h1$length * h1$length
length3 <- length2 * h1$length
length4 <- length3 * h1$length
length5 <- length4 * h1$length

fit <- lm(h1$rawscore ~ h1$length + length2 + length3 + length4 + length5)

summary(fit)

h1$rawscoreHat <- fitted(fit)

h1$score <- h1$rawscore - h1$rawscoreHat
h1$len <- round_any(h1$length, 1000, f = ceiling)

write.csv(h1,"C:/data2/voluntary.h2.score.txt", row.names = FALSE)


#using pelt CROPS
library(changepoint)
library(dplyr)
library(ggplot2)

air_data <- readRDS("C:/Users/anthony/Desktop/my_project/census-app/data/Air_box.rds")

PM25_of_sensor <- subset(air_data, ID == sensor_ID[13])
del_index_arr = group_by(PM25_of_sensor, as.Date(f_time, tz = "Etc/GMT+8")) %>%
summarise( length(PM25) > 4 ) #change point detection is not available when length is shorter than 4

Day_ID <- unique(as.Date(PM25_of_sensor$f_time, tz = "Etc/GMT+8"))
del_index = which(as.data.frame(del_index_arr[,2])[,1] %in% 0)

if(length(del_index) != 0) PM25_of_sensor <- PM25_of_sensor[ -which( Day_ID[del_index] == as.Date(PM25_of_sensor$f_time, tz = "Etc/GMT+8") ),]
#get Day_ID after deleting the ones with length shorter than 4
Day_ID <- unique(as.Date(PM25_of_sensor$f_time, tz = "Etc/GMT+8"))

sen_of_day <- PM25_of_sensor[which(as.Date(PM25_of_sensor$f_time, tz = "Etc/GMT+8") == Day_ID[1]),]

pelt_1 <- cpt.meanvar(sen_of_day$PM25, pen.value = c(4,1500), penalty = "CROPS", method = "PELT") #call by cpts(pelt)
possible_ncpts <- unique(apply(pelt_1@cpts.full, 2, function(x) length(which(!is.na(x)))))

crop_matrix <- cpts.full(pelt_1)
crop_index <-crop_matrix[ nrow(crop_matrix) - 7,]

j <- 1
cpt_vec <- vector(mode="numeric", length=0)
today_time <- as.POSIXct(sen_of_day$f_time, tz = "Etc/GMT+8")
for(i in crop_index[!is.na(crop_index)]){
	cpt_vec[j:i-1] <- mean(sen_of_day$PM25[j:i-1])
	cpt_vec[i-1] <- NA
	j <- i+1
	print(cpt_vec)
}

i <- length( sen_of_day$PM25 )
cpt_vec[j:i] <- mean(sen_of_day$PM25[j:i])
p <- ggplot(sen_of_day,
	aes(today_time, PM25)) +
	geom_line() + xlab("PM2.5") + ylab("Time") +
	geom_line(aes(today_time, cpt_vec,na.rm = TRUE), colour = "red")
#

# cpt_vec <- vector(mode="numeric", length=0)
# j <- 1
#
# for(i in crop_index[!is.na(crop_index)]){
#   p <- p + geom_line(
#         aes(x = as.POSIXct(sen_of_day$f_time[i], tz = "Etc/GMT+8"), y = mean(sen_of_day$PM25[j:i]),
#         xend = as.POSIXct(sen_of_day$f_time[j], tz = "Etc/GMT+8"), yend = mean(sen_of_day$PM25[j:i]),
#         colour = "segment")
#         )
#   print(j:i)
#   j <- i+1
# }
#
# print(p)


a -> b (5): 2
a -> d (1): 1
a -> c (0): 0
a -> e (0): 0
b -> c (6): 3
b -> a (0): 3
c -> a (7): 7
c -> e (3): 0
c -> b (0): 3
c -> d (0): 0
d -> c (2): 2
d -> a (0): 0
e -> a (4): 4
e -> c (0): 3


my.dev<-'screen'
my.dev<-'png'

letterSize<-1.5;  # use 3 for the Baltic (3x3 plot)and 0.5 for the North Sea (9x9)

Init.function() # get SMS.contol object  including sp.names

if (T)  {  # use only years that were uese to estimate stock recruitment  relation
  SSB.R.year.first<-SMS.control@SSB.R.year.first
  SSB.R.year.last <-SMS.control@SSB.R.year.last
  SSB.R.year.first[SSB.R.year.first==-1]<-SMS.control@first.year.model
  SSB.R.year.last[SSB.R.year.last==-1]<-SMS.control@last.year.model
} else {
  SSB.R.year.first<-SMS.control@SSB.R.year.first
  SSB.R.year.last <-SMS.control@SSB.R.year.last
  SSB.R.year.first[]<-SMS.control@first.year.model
  SSB.R.year.last[]<-SMS.control@last.year.model
}

rec.age<-SMS.control@first.age
rec.quarter<- SMS.control@rec.season
simple.recruit.per.spawner.analysis<-F    # FALSE=used residuals from S/R, TRUE=use simple recruitment per SSB

use.only.years.included.in.the.fit<-T

if (F) {
  rec.age<-1  # just testing
  rec.quarter<- 1
  simple.recruit.per.spawner.analysis<-T
}

# extract SSB and Recruits
s<-Read.summary.data()
s1<-subset(s,Quarter==1 & Year<=SMS.control@last.year.model-rec.age & Species.n>=first.VPA)
ssb<-tapply(s1$SSB,list(s1$Year,s1$Species.n),sum)

rec<-subset(s,Quarter==rec.quarter & Species.n>=first.VPA,select=c(Year,Species.n,Age,N))

rec<-subset(rec,Age==rec.age & Year>=SMS.control@first.year.model+rec.age)
rec<-subset(rec,Year<=SMS.control@last.year.model)

rec<-tapply(rec$N,list(rec$Year,rec$Species.n),sum)
dim(ssb);dim(rec)
dim(ssb)==dim(rec)

if (use.only.years.included.in.the.fit) {
  # read recruiment years used
  recruit.years<-matrix(scan(file='recruitment_years.in',comment.char='#'),nrow=dim(rec)[2],byrow=T)
  colnames(recruit.years)<-c(as.character(seq(SMS.control@first.year,SMS.control@last.year)))
  recruit.years<-t(recruit.years)
  recruit.years<- recruit.years[dimnames(ssb)[[1]],]
  rec[recruit.years==0]<-NA
}

#read SSB/R parameters
 p<-Read.SSB.Rec.data()

model.name<-c('Ricker','Bev. & Holt','Geom. mean','Hockey stick')

SSB_R<-function(x,cutof=T) {
    delta<-0.5
    y<-x  # copy structure
    #print(c(alfa,beta,exp(alfa+beta)))
    if (model==1) y<-alfa*x*exp(-beta*x)
    else if (model==51 | model==52) y<-alfa*x*exp(-beta*x+info1*info2)
    else if (model==2) y[]<-alfa*x/(1+x*beta)
    else if (model==3) y[]<-rep(exp(alfa),length(x))
    else if (model==4) {for (ii in (1:length(x))) y[i]<-exp(alfa)*min(x[i],exp(beta))}
    else if (model==5) {for (ii in (1:length(x))) {
        if (x[ii]<=(exp(beta)*(1-delta))) y[ii]<-exp(alfa)*x[ii]
        else if (x[ii]< exp(beta)*(1+delta)) y[ii]=exp(alfa)*(x[ii]-(((x[ii]-exp(beta)*(1+delta))^2)/(4*delta*exp(beta))))
        else if (x[ii]>=exp(beta)*(1+delta)) y[ii]<=exp(alfa+beta)
        else x[i]<-NA
        }}
    else if (model==100) {for (ii in (1:length(x))) y[ii]<-exp(alfa)*min(x[ii],beta)}

    if (SMS.control@SSB.R.year.first[s.index]> -1 & cutof==T) {
      y[as.character(SMS.control@first.year.model:(SMS.control@SSB.R.year.first[s.index]-1))] <-NA
     }
    return(y)
}

ss<-as.character(seq(first.VPA,nsp))

########################
# residuals
s.index<-0
est.rec<-rec # copy structure
i<-0

for (sp in ss) {
  s.index<-s.index+1
  model<-p[s.index,'model']
  alfa<-p[s.index,'alfa']
  beta<-p[s.index,'beta']
  info1<-p[s.index,'info1']
  info2<-p[s.index,'info2']

  est.rec[,s.index]<-SSB_R(x=ssb[,s.index])
}

 rec.resid<-rec/est.rec   # Default
#rec.resid<-rec   # just testing

first.year<-max(SMS.control@SSB.R.year.first)

#this is the closest we get to the SMS estimate of std,
#inp<-log(rec.resid[as.character(first.year:SMS.control@last.year.model),] )
inp<-log(rec.resid)
if (simple.recruit.per.spawner.analysis) inp<-rec/ssb
dimnames(inp)[[2]]<-sp.names[as.numeric(colnames(inp))]

    out<-matrix(1,nrow=length(dimnames(inp)[[2]]),ncol=length(dimnames(inp)[[2]]))
    dimnames(out)<-list(dimnames(inp)[[2]],dimnames(inp)[[2]])
   for (sp1 in  dimnames(inp)[[2]])   for (sp2 in  dimnames(inp)[[2]]) {
    if (sp1 !=sp2) {
      a<-cor.test(inp[,sp1],inp[,sp2])
      out[sp1,sp2]<-a$p.val
    }
   }
   round(out,3)
   out.old<-out

V<-var(inp,use = "complete");V

write.table(V,file= file<-file.path(data.path,'covariance_rec.in'),row.names=F,col.names=F)

#mvrnorm(n=1, mu=rep(0,dim(V)[1]), Sigma=V)

sqrt(diag(V))      #this is the closest we get to the SMS estimate of  sd,  file SSB_R.out
COR<-cov2cor(V)
COR

i<-dim(inp)[2]
xy<-expand.grid(x=1:i,y=1:i)

plotC<-function(x,y) {
   a<- cor.test(inp[,x],inp[,y])
   plot(inp[,x],inp[,y],xlab=dimnames(inp)[[2]][x],ylab=dimnames(inp)[[2]][y],main=round(a$p.val,2))
    z <- lm(inp[,y] ~ inp[,x])
    abline(z)
}

cleanup()
newplot(dev='screen',nox=i,noy=i);
par(mar=c(1,1,1,1))
for (a in (1:dim(xy)[1])) plotC(xy[a,'x'],xy[a,'y'])

make.template<-function(sp,tit='Yield',my.dev='png') {

  p<-0.05
  n<-length(sp)

  des<-matrix(c(
          p,1,1-p,1,   # 1 Yield title
          0,0.1,0,1-p, # 2 F title
          p,1,0,1-p)    # 3 figures
          , nrow=3, ncol=4, byrow=TRUE)
  split.screen(des)     # split display into three screens
  split.screen(c(2,1), screen = 1) # top split yield title in two lines, screen 4 & 5
  split.screen(c(1,n), screen = 5) # top split yield  screen 5 into n screens e.g. 6:13
  split.screen(c(n,1), screen = 2) # split into n.species rows

  split.screen(c(n,n), screen = 3) # Split plot area into n x n graphs

  screen(3); par(mar=c(0,0,1,0));  mtext(tit,side=3)
  for (i in (1:n)) { screen(i+5);par(mar=c(0,0,1.2,0)); mtext(paste(sp[i],'    '),3,cex=letterSize,adj=1) }
  if (my.dev!='png') for (i in (1:n)) { screen(i+n+5); par(mar=c(1,0,0,0));mtext(paste(sp[i],'      '),side=1,cex=0.8) } else {
     for (i in (1:n)) { screen(i+n+5); par(mar=c(1,0,0,0));mtext(paste(" ",substr(sp[i],1,3),'  '),side=1,adj = 0,cex=0.8) }
  }
}

new.screen<-function(coln=1,rown=1) {
  sc<-first.sc-1+(rown-1)*n.species+coln
  #cat('column:',coln,' row:',rown,' screen:',sc,'\n')
  screen(sc)
  par(mar=c(0.1,0,1,1))    #bottom, left, top, right
  par(cex.axis=0.1)
  #sc<<-sc+1
}

plotC2<-function(x,y) {
   new.screen(x,y)
   a<- cor.test(inp[,x],inp[,y])
   plot(inp[,x],inp[,y],axes=F,xlab=NULL,ylab=NULL,cex = letterSize)
   box()
   col<-'black'; if (a$p.val<=0.05 & a$p.val>0 ) col<-"red"
   title(paste('cor=',formatC(COR[x,y],digits = 2, format = "f"),' p-val=',formatC(a$p.val,digits = 2, format = "f"),sep=''), cex.main = letterSize/2,   col.main= col)
    z <- lm(inp[,y] ~ inp[,x])
    abline(z,col='blue',lwd=2)
}

# acf(inp[,1])

cleanup()

nox<-1; noy<-1;
noxy<-nox*noy

newplot(dev=my.dev,filename='recruit_correlation',nox,noy,Portrait=T,w8=12,w11=14);

n.species<-dim(inp)[[2]]
first.sc<-n.species*2+6  # first screen for plot

make.template(dimnames(inp)[[2]],tit='')
for (aa in (1:dim(xy)[1])) plotC2(xy[aa,'x'],xy[aa,'y'])

if (my.dev=='png') cleanup()

if (F) {
    ###################  to test it works
    # 1. run the OP program to produce file  OP_condensed.out

    # estimate COV from output
    # extract SSB and Recruits
    s<-Read.OP.condensed(dir=file.path(data.path,scenario))
    ssb<-tapply(s$SSB,list(s$Year,s$Species.n),sum)
    rec<-tapply(s$recruit,list(s$Year,s$Species.n),sum)

    ########################
    # residuals
    s.index<-0
    est.rec<-rec # copy structure
    i<-0

    for (sp in ss) {
      s.index<-s.index+1
      model<-p[s.index,'model']
      alfa<-p[s.index,'alfa']
      beta<-p[s.index,'beta']
      info1<-p[s.index,'info1']
      info2<-p[s.index,'info2']

      est.rec[,s.index]<-SSB_R(x=ssb[,s.index],cutof=F)
    }

    rec.resid<-rec/est.rec

    inp<-log(rec.resid)
    dimnames(inp)[[2]]<-sp.names[as.numeric(colnames(inp))]
    Vnew<-var(inp);

    cat(rep('\n',3))
    V
    Vnew

    cat(rep('\n',3))
    sqrt(diag(V))     #this is the closest we get to the SMS estimate of sd,  file SSB_R.out
    sqrt(diag(Vnew))

    CORnew<-cov2cor(Vnew)
    cat(rep('\n',3))
    print(round(COR,2))
    print(round(CORnew,2))

    out<-matrix(1,nrow=length(dimnames(inp)[[2]]),ncol=length(dimnames(inp)[[2]]))
    dimnames(out)<-list(dimnames(inp)[[2]],dimnames(inp)[[2]])
   for (sp1 in  dimnames(inp)[[2]])   for (sp2 in  dimnames(inp)[[2]]) {
    if (sp1 !=sp2) {
      a<-cor.test(inp[,sp1],inp[,sp2])
      out[sp1,sp2]<-a$p.val
    }
   }
   print(round(out,2))
   print(round(out.old,2))
   out1<-out
   out2<-out.old
   out1[out1>0.05]<-99
   out2[out2>0.05]<-99
   round(out1,2)
   round(out2,2)

    ####
    if (F) {
      aa<-matrix(scan(file.path(data.path,'OP_testOut.out')),byrow=T,ncol=3)
      aa<-log(aa)
      cov(aa)
      (diag(cov(aa)))
      cor(aa)
    }
 }


# Use stepwise regression and PCA to confirm discriminating questions between groups

rm(list = ls())

source("../project_support.r")

# Check if additional libraries are installed and if they are not installed, install them
packages <- c("MASS", "factoextra", "ggfortify")
install.packages(setdiff(packages, rownames(installed.packages())))

# Load additional libraries
# This will break a lot of the code which relies on dplyr::select
# so run this code separately to the main analysis
library(MASS)
library(factoextra)
library(ggfortify)

# Load additional functions

# Perform stepwise regression
stepwise_regression <- function(data, cluster1, cluster2, value_cluster1, value_cluster2) {
  clusters <- data %>%
    mutate(Cluster = case_when(Cluster %in% cluster1 ~ value_cluster1,
                               Cluster %in% cluster2 ~ value_cluster2)) %>%
    filter(!is.na(Cluster)) %>%
    mutate(Cluster = as.numeric(as.character(Cluster))) %>%
    dplyr::select(-ID, -`Entry ID`, -`Branching question`, -`Entry name`, -`Entry source`, -`Entry description`, -`Entry tags`, -Expert, -`Region ID`, -`Region name`, -`Region description`, -`Region tags`, -label, -elite, -non_elite, -religious_specialist)
  clusters[clusters == "{01}"] <- "3"
  clusters <- clusters %>%
    mutate_if(is.character, as.numeric)
  # Remove non changing columns
  non_changing <- lapply(clusters, unique)
  non_changing <- non_changing[lengths(non_changing)== 1]
  non_changing <- names(non_changing)
  clusters <- clusters %>%
    dplyr::select(-all_of(non_changing))
  # Fit the full model
  full_model <- lm(Cluster ~ ., data = clusters)
  # Stepwise regression model
  step_model <- stepAIC(full_model, direction = "both", trace = FALSE)
}

# Extract questions selected by stepwise regression
extract_questions <- function(lm, questions){
  # Extract Questions IDs from lm call
  x = lm$call
  x = as.character(x)
  x = x[2]
  x = unlist(str_split(x, "\\+"))
  x = gsub("Cluster ~ `", "", x)
  x = gsub("`", "", x)
  x = gsub("\n", "", x)
  x = str_trim(x)
  x = as.numeric(x)
  # Extract question metadata
  used_questions = questions %>%
    filter(`Question ID` %in% x)
}

# Load data
data <- read_csv("./input/b_f_r4_50_50.csv")
raw_data <- read_csv("./input/drh.csv")

# Extract all questions from drh data
questions <- raw_data %>%
  dplyr::select(`Question ID`, Question, `Question description`, `Parent question`, `Parent question ID`) %>%
  distinct()

# Stepwise regression
step_model <- stepwise_regression(data = data, cluster1 = c("1.1", "1.2"), cluster2 = c("2.1.1", "2.1.2", "2.2"), value_cluster1 = 1, value_cluster2 = 2)

# Extract used questions
used_questions <- extract_questions(step_model, questions)

# Remove metadata
data_sub <- data %>%
  dplyr::select(-ID, -`Entry ID`, -`Branching question`, -`Entry name`, -`Entry source`, -`Entry description`, -`Entry tags`, -Expert, -`Region ID`, -`Region name`, -`Region description`, -`Region tags`, -label, -elite, -non_elite, -religious_specialist)
data_sub[data_sub == "{01}"] <- "3"
data_sub <- data_sub %>%
  mutate(Cluster = as.factor(Cluster)) %>%
  mutate_if(is.character, as.numeric)

# Perform PCA
pca <- prcomp(dplyr::select(data_sub, -Cluster))

# Plot PCA
autoplot(pca, data = data_sub, colour = 'Cluster') +
  theme_minimal() +
  scale_color_manual(values = c("#E69F00", "#56B4E9", "#009E73", "#F0E442", "#0072B2"))

# Visualize variables
fviz_pca_var(pca, col.var = "contrib",
             gradient.cols = c("#00AFBB", "#E7B800", "#FC4E07")
)

# Extract the results for variables
pca_var <- get_pca_var(pca)

# Select variables that are most contributing to PC1 and PC2
pc1 <- tibble(`Question ID` = names(pca_var$contrib[,1]), contrib = pca_var$contrib[,1]) %>%
  mutate(`Question ID` = as.numeric(`Question ID`)) %>%
  left_join(questions) %>%
  filter(contrib > 1) %>%
  arrange(desc(contrib))
pc2 <- tibble(`Question ID` = names(pca_var$contrib[,2]), contrib = pca_var$contrib[,2]) %>%
  mutate(`Question ID` = as.numeric(`Question ID`)) %>%
  left_join(questions) %>%
  filter(contrib > 1) %>%
  arrange(desc(contrib))


year = commandArgs(T)
d = as.Date(paste0(year, "-01-01"))
fridays = d + seq(by = 7,
    (5 - as.POSIXlt(d)$wday) %% 7,
    364 + (months(d + 30 + 29) == "February"))
message(paste(collapse = "\n", fridays[tapply(
    seq_along(fridays), as.POSIXlt(fridays)$mon, max)]))


n <- 0

check <- FALSE
while (!check) {
    n <- n + 380
    check <- TRUE
    for (m in 19:1) {
        if (n %% m != 0) {
            check <- FALSE
            break
        }
    }
}

cat(n, "\n")


"calibration" <-
      function(obs, preds, family = "binomial")
      {
      #
      # j elith/j leathwick 17th March 2005
      # calculates calibration statistics for either binomial or count data
      # but the family argument must be specified for the latter
      # a conditional test for the latter will catch most failures to specify
      # the family
      #

      if (family == "bernoulli") family <- "binomial"
      pred.range <- max(preds) - min(preds)
      if(pred.range > 1.2 & family == "binomial") {
      print(paste("range of response variable is ", round(pred.range, 2)), sep = "", quote = F)
      print("check family specification", quote = F)
      return()
      }
      if(family == "binomial") {
      pred <- preds + 1e-005
      pred[pred >= 1] <- 0.99999
      mod <- glm(obs ~ log((pred)/(1 - (pred))), family = binomial)
      lp <- log((pred)/(1 - (pred)))
      a0b1 <- glm(obs ~ offset(lp) - 1, family = binomial)
      miller1 <- 1 - pchisq(a0b1$deviance - mod$deviance, 2)
      ab1 <- glm(obs ~ offset(lp), family = binomial)
      miller2 <- 1 - pchisq(a0b1$deviance - ab1$deviance, 1)
      miller3 <- 1 - pchisq(ab1$deviance - mod$deviance, 1)
      }
      if(family == "poisson") {
      mod <- glm(obs ~ log(preds), family = poisson)
      lp <- log(preds)
      a0b1 <- glm(obs ~ offset(lp) - 1, family = poisson)
      miller1 <- 1 - pchisq(a0b1$deviance - mod$deviance, 2)
      ab1 <- glm(obs ~ offset(lp), family = poisson)
      miller2 <- 1 - pchisq(a0b1$deviance - ab1$deviance, 1)
      miller3 <- 1 - pchisq(ab1$deviance - mod$deviance, 1)
      }
      calibration.result <- c(mod$coef, miller1, miller2, miller3)
      names(calibration.result) <- c("intercept", "slope", "testa0b1", "testa0|b1", "testb1|a")
      return(calibration.result)
}

"calc.dev" <-
        function(obs.values, fitted.values, weights = rep(1,length(obs.values)), family="binomial", calc.mean = TRUE)
        {
        # j. leathwick/j. elith
        #
        # version 2.1 - 5th Sept 2005
        #
        # function to calculate deviance given two vectors of raw and fitted values
        # requires a family argument which is set to binomial by default
        #
        #

        if (length(obs.values) != length(fitted.values))
           stop("observations and predictions must be of equal length")

        y_i <- obs.values

        u_i <- fitted.values

        if (family == "binomial" | family == "bernoulli") {

           deviance.contribs <- (y_i * log(u_i)) + ((1-y_i) * log(1 - u_i))
           deviance <- -2 * sum(deviance.contribs * weights)

        }

        if (family == "poisson" | family == "Poisson") {

            deviance.contribs <- ifelse(y_i == 0, 0, (y_i * log(y_i/u_i))) - (y_i - u_i)
            deviance <- 2 * sum(deviance.contribs * weights)

        }

        if (family == "laplace") {
            deviance <- sum(abs(y_i - u_i))
            }

        if (family == "gaussian") {
            deviance <- sum((y_i - u_i) * (y_i - u_i))
            }

        if (calc.mean) deviance <- deviance/length(obs.values)
        dev=list(deviance=deviance,dev.cont=deviance.contribs)
        return(dev)

}

beachcolours<-function (heightrange, sealevel = 0, monochrome = FALSE, ncolours = if (monochrome) 16 else 64)
{
#this function was robbed from the spatstat library internals
    if (monochrome)
        return(grey(seq(0, 1, length = ncolours)))
    stopifnot(is.numeric(heightrange) && length(heightrange) ==
        2)
    stopifnot(all(is.finite(heightrange)))
    depths <- heightrange[1]
    peaks <- heightrange[2]
    dv <- diff(heightrange)/(ncolours - 1)
    epsilon <- dv/2
    lowtide <- max(sealevel - epsilon, depths)
    hightide <- min(sealevel + epsilon, peaks)
    countbetween <- function(a, b, delta) {
        max(0, round((b - a)/delta))
    }
    nsea <- countbetween(depths, lowtide, dv)
    nbeach <- countbetween(lowtide, hightide, dv)
    nland <- countbetween(hightide, peaks, dv)
    colours <- character(0)
    if (nsea > 0)
        colours <- rev(rainbow(nsea, start = 3/6, end = 4/6))
    if (nbeach > 0)
        colours <- c(colours, rev(rainbow(nbeach, start = 3/12,
            end = 5/12)))
    if (nland > 0)
        colours <- c(colours, rev(rainbow(nland, start = 0, end = 1/6)))
    return(colours)
}


#' @export
#' @title blue.red
#' @description This function generates a vector of shades from blue to red of a length selected by value of \code{n}.
#' @param \code{n} = the number of colors desired
#' @return character vector
#' @examples
#' blue.red(5)
#' [1] "#0000FF" "#FFFFFF" "#FFFFFF" "#FF0000"
#' @note As of 2016-06-14, this function generates an error: unused argument (gamma = gamma).  It appears to be attempting to generate a hsv value by adding a gamma value at the end of a hex value.  Removing \code{, gamma=gamma} generates the expected ramp.
#' @author  unknown, \email{<unknown>@@dfo-mpo.gc.ca}
#' @export
blue.red <- function (n)
  {
    n = n-2
    if ((n <- as.integer(n[1])) > 0) {
      even.n <- n%%2 == 0
      green = 2/6
      red = 0
      blue = 4/6
      gamma = 1.6
      k <- n%/%2
      l1 <- k + 1 - even.n
      l2 <- n - k + even.n
      c( if (l1 > 0) {
            hsv( h = blue,
                 s = seq(1, ifelse(even.n, 1/k, 0), length = l1),
                 v = 1)
          },
         if (l2 > 1) {
           hsv( h = red,
                s = seq(0, 1, length = l2),
                v = 1,
                gamma=gamma)
         }
       )
    }
  }


#' Method of RCTtoolbox: \code{balance()}
#'
#' When you create R6 object "RCTtoolbox"
#' via \code{\link{create_RCTtoolbox}}
#' and run its method \code{balance()},
#' the method internally implements a function
#' that performs balance test.
#' The method \code{balance()} provides some arguments.
#' See the section "Arguments."
#'
#' @param ctrl character. New control arm.
#' If NULL (default),
#' the first element of \code{treat_levels} is control arm.
#' @param subset subset condition.
#' If NULL (default),
#' full observations of \code{data} is used to implement balance test.
#' @param weights weight variable for weighted least squares.
#' If NULL (default), implement ordinary least squares.
#' @param cluster cluster variable for clustered standard error.
#' If NULL (default), standard error is not clustered.
#' @param \dots arguments passed to \code{\link[estimatr]{lm_robust}}.
#'
#' @return R6 object with "RCTtoolbox.balance.test" class.
#' The returned object has following field and methods:
#' \describe{
#'   \item{\code{result}}{Field.
#'     Data frame including estimated result.
#'     See the section "Data Field."}
#'   \item{\code{print()}}{Method.
#'     Print information about the returned object.
#'     Run \code{$print()}.}
#'   \item{\code{table()}}{Method.
#'     Create output table of balance test.
#'     Run \code{$table()}.}
#' }
#'
#' @section Result Field:
#' The R6 object with "RCTtoolbox.balance.test" class has \code{result} field.
#' This field has a data frame with 3 variables:
#' \describe{
#'   \item{x}{Character. Covariates.}
#'   \item{item}{Factor.
#'     Label of experimental arms, f-value,
#'     degree of freedoms of F-distribution, p-value of F.}
#'   \item{val}{Numeric. Value corresponding to item.}
#' }
#'
#' @section Developer Note:
#' The method \code{balance()} provided by R6 object RCTtoolbox
#' implements \code{RCTtoolbox.balance.test$new()}
#' which generates R6 object with "RCTtoolbox.balance.test" class.
#' Initialization of R6 object "RCTtoolbox.balance.test" run
#' \code{balance_test_multi_var(private$xvec, private$dvec,
#' self$data, private$dvec.levels, private$dvec.labels, ...)}
#' where \code{...} accepts arguments explained in the section "Arguments."
#' The first five arguments passed to \code{balance_test_multi_var()} are
#' \describe{
#'   \item{\code{covariate}}{Character vector. Covariate.
#'     The method \code{balance()} automatically
#'     passes the private field \code{xvec} of R6 object "RCTtoolbox"
#'     to this argument.}
#'   \item{\code{treat}}{Character vector. Treatment.
#'     The method \code{balance()} automatically
#'     passes the private field \code{dvec} of R6 object "RCTtoolbox"
#'     to this argument.}
#'   \item{\code{data}}{data.frame/tibble object that you want to use.
#'     The method \code{ttest()} automatically
#'     passes a public field \code{data} of R6 object "RCTtoolbox"
#'     to this argument.}
#'   \item{\code{treat_levels}}{character vector. Level of experimental arms.
#'     The first element is control arm.
#'     The method \code{ttest()} automatically
#'     passes the private field \code{dvec.levels} of R6 object "RCTtoolbox"
#'     to this argument.}
#'   \item{\code{treat_labels}}{character vector. Label of experimental arms
#'     corresponding to \code{treat_levels}.
#'     The method \code{ttest()} automatically
#'     passes the private field \code{dvec.labels} of R6 object "RCTtoolbox"
#'     to this argument.}
#' }
#'
#' @examples
#' \dontrun{
#'   data(RubellaNudge)
#'   rct <- create_RCTtoolbox(
#'     atest + avacc ~ treat,
#'     ~ age + educ,
#'     RubellaNudge,
#'     LETTERS[1:7]
#'   )
#'
#' # balance test
#' rct$balance()$result
#' }
#'
#' @name balance
#'
NULL


splitnum <- function(s) {
  r <- 0
  v <- 0
  o <- 1
  d <- 1
  for (i in 1:nchar(s[2])) {
    c <- substr(s[2], i, i)
    if (c == '+') {
      r <- r + v*o
      o <- 1
      v <- 0
    } else if (c == '-') {
      r <- r + v*o
      o <- -1
      v <- 0
    } else {
      v <- v*10 + as.integer(substr(s[1], d, d))
      d <- d + 1
    }
  }
  r + v*o
}

cat(sapply(strsplit(readLines(tail(commandArgs(), n=1)), " "), splitnum), sep="\n")


#' Compute confusion matrix on metacells
#'
#' @param mc_id meta cell object
#' @param graph_id graph object
#' @param K Knn parameter for filtering graph edges
#'
#' @export

mcell_mc_confusion_mat = function(mc_id, graph_id, K, ignore_mismatch = F)
{
	graph = scdb_cgraph(graph_id)
	if(is.null(graph)) {
		stop("MC-ERR: cell graph id ", graph_id, " is missing when computing mc confusion")
	}
	mc = scdb_mc(mc_id)
	if(is.null(mc)) {
		stop("MC-ERR: mc id ", mc_id, " is missing when computing mc confusion")
	}
	if(!ignore_mismatch & !mcell_mc_match_graph(mc_id, graph_id)) {
		stop("MC-ERR: graph is missing some of the cells in the mc cover when computing confusion, halting")
	}

#filter top K edges
	deg = nrow(graph@edges)/length(graph@nodes)
	T_w = 1-(K+1)/deg
	edges = graph@edges
	f = edges$w > T_w
#factor of edgesfactor(as.character(resamp$co_cluster$node1),

#	mc_map = mc@mc[as.character(levels(edges$mc1))]
#	mc_map = factor(as.character(lresamp$co_cluster$node1 = factor(as.character(resamp$co_cluster$node1), levels=orig_levels)
	mc_map = rep(NA, length(levels(edges$mc1)))

	f = names(mc@mc) %in% levels(edges$mc1)
	mc_map[factor(names(mc@mc)[f],levels(edges$mc1))] = mc@mc[f]
	mc1 = mc_map[edges$mc1[f]]
	mc2 = mc_map[edges$mc2[f]]
	N = max(mc1, mc2, na.rm=T)

	confu = matrix(tabulate((mc1-1)*N+mc2, nbins=N*N), nrow=N)
	rownames(confu) = 1:N
	colnames(confu) = 1:N
	return(confu)
}

#' Compute confusion matrix on metacells using a coclustering object
#'
#' @param mc_id meta cell object
#' @param coc_id cocluster object id
#' @param K top K coclustering neighbors will be used for each cell
#'
#' @export

mcell_mc_coclust_confusion_mat = function(mc_id, coc_id, K, ignore_mismatch = F, alpha=2)
{
	coc = scdb_coclust(coc_id)
	if(is.null(coc)) {
		stop("MC-ERR: coclust id ",coc_id, " is missing when computing mc coclust confusion")
	}
	mc = scdb_mc(mc_id)
	if(is.null(mc)) {
		stop("MC-ERR: mc id ", mc_id, " is missing when computing mc confusion")
	}

	edges = coc@coclust
	filt_edges = mcell_coclust_filt_by_k_deg(coc_id, K, alpha)
	edges = edges[filt_edges,]
#filter top K edges
#factor of edges$mc1 and factor of mc may be different
	mc_map = mc@mc[as.character(levels(edges$node1))]
	mc1 = mc_map[edges$node1]
	mc2 = mc_map[edges$node2]
	N = max(mc1, mc2, na.rm=T)

	confu = matrix(tabulate((mc1-1)*N+mc2, nbins=N*N), nrow=N)
	rownames(confu) = 1:N
	colnames(confu) = 1:N
	return(confu)
}

#' Compute cell homogeneity - the fraction of intra mc edges per cell
#'
#' @param mc_id meta cell object
#' @param graph_id graph object
#'
#' @export

mcell_mc_cell_homogeneity = function(mc_id, graph_id, ignore_mis=F, T_w = 0)
{
	graph = scdb_cgraph(graph_id)
	if(is.null(graph)) {
		stop("MC-ERR: cell graph id ", graph_id, " is missing when computing mc confusion")
	}
	mc = scdb_mc(mc_id)
	if(is.null(mc)) {
		stop("MC-ERR: mc id ", mc_id, " is missing when computing mc confusion")
	}
	if(!ignore_mis & !mcell_mc_match_graph(mc_id, graph_id)) {
		stop("MC-ERR: graph is missing some of the cells in the mc cover when computing confusion, halting")
	}
#filter top K edges
	edges = graph@edges
	if(T_w != 0) {
		edges = edges[edges$w >= T_w,]
	}
#factor of edges$mc1 and factor of mc may be different
	mc_map = mc@mc[as.character(levels(edges$mc1))]
	intra_mc = mc_map[edges$mc1] == mc_map[edges$mc2]
	f = !is.na(intra_mc)

	N = max(as.integer(edges$mc1),na.rm=T)
	intra_stat = tabulate(as.integer(edges$mc1[f])*2 - ifelse(intra_mc[f],0,1), nbins = N*2)

	homogeneity = t(matrix(intra_stat, nrow=2))
	rownames(homogeneity) = levels(edges$mc1)
	homogeneity = homogeneity[intersect(levels(edges$mc1), names(mc@mc)),]
	colnames(homogeneity) = c("out", "in")
	return(homogeneity)
}