# Source: https://www.shirin-glander.de/2018/06/keras_fruits/
# Author: Dr. Shirin Elsinghorst - https://github.com/ShirinG
# Data: https://www.kaggle.com/moltean/fruits/data

library(keras)

# list of fruits to modle
fruit_list <- c("Kiwi", "Banana", "Apricot", "Avocado", "Cocos", "Clementine", "Mandarine", "Orange",
                "Limes", "Lemon", "Peach", "Plum", "Raspberry", "Strawberry", "Pineapple", "Pomegranate")

# number of output classes (i.e. fruits)
output_n <- length(fruit_list)

# image size to scale down to (original images are 100 x 100 px)
img_width <- 20
img_height <- 20
target_size <- c(img_width, img_height)

# RGB = 3 channels
channels <- 3

# optional data augmentation
train_data_gen = image_data_generator(
  rescale = 1/255 #,
  #rotation_range = 40,
  #width_shift_range = 0.2,
  #height_shift_range = 0.2,
  #shear_range = 0.2,
  #zoom_range = 0.2,
  #horizontal_flip = TRUE,
  #fill_mode = "nearest"
)

# Validation data shouldn't be augmented! But it should also be scaled.
valid_data_gen <- image_data_generator(
  rescale = 1/255
)

path_prefix <- paste(getwd(), "/data/fruit/", sep="")
# path to image folders
train_image_files_path <- paste(path_prefix, "training/", sep="")
valid_image_files_path <- paste(path_prefix, "validation/", sep="")

# training images
train_image_array_gen <- flow_images_from_directory(train_image_files_path,
                                                    train_data_gen,
                                                    target_size = target_size,
                                                    class_mode = "categorical",
                                                    classes = fruit_list,
                                                    seed = 42)

# validation images
valid_image_array_gen <- flow_images_from_directory(valid_image_files_path,
                                                    valid_data_gen,
                                                    target_size = target_size,
                                                    class_mode = "categorical",
                                                    classes = fruit_list,
                                                    seed = 42)

cat("Number of images per class:")
## Number of images per class:
table(factor(train_image_array_gen$classes))

## Class label vs index mapping:
train_image_array_gen$class_indices
fruits_classes_indices <- train_image_array_gen$class_indices
save(fruits_classes_indices, file = paste(path_prefix, "fruits_classes_indices.RData", sep=""))

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

# number of training samples
train_samples <- train_image_array_gen$n
# number of validation samples
valid_samples <- valid_image_array_gen$n

# define batch size and number of epochs
batch_size <- 32
epochs <- 10

# initialise model
model <- keras_model_sequential()

# add layers
model %>%
  layer_conv_2d(filter = 32, kernel_size = c(3,3), padding = "same", input_shape = c(img_width, img_height, channels)) %>%
  layer_activation("relu") %>%

  # Second hidden layer
  layer_conv_2d(filter = 16, kernel_size = c(3,3), padding = "same") %>%
  layer_activation_leaky_relu(0.5) %>%
  layer_batch_normalization() %>%

  # Use max pooling
  layer_max_pooling_2d(pool_size = c(2,2)) %>%
  layer_dropout(0.25) %>%

  # Flatten max filtered output into feature vector
  # and feed into dense layer
  layer_flatten() %>%
  layer_dense(100) %>%
  layer_activation("relu") %>%
  layer_dropout(0.5) %>%

  # Outputs from dense layer are projected onto output layer
  layer_dense(output_n) %>%
  layer_activation("softmax")

# compile
model %>% compile(
  loss = "categorical_crossentropy",
  optimizer = optimizer_rmsprop(lr = 0.0001, decay = 1e-6),
  metrics = "accuracy"
)

# fit
hist <- model %>% fit_generator(
  # training data
  train_image_array_gen,

  # epochs
  steps_per_epoch = as.integer(train_samples / batch_size),
  epochs = epochs,

  # validation data
  validation_data = valid_image_array_gen,
  validation_steps = as.integer(valid_samples / batch_size),

  # print progress
  verbose = 2,
  callbacks = list(
    # save best model after every epoch
    callback_model_checkpoint(paste(path_prefix, "fruit_checkpoints.h5", sep=""), save_best_only = TRUE),
    # only needed for visualising with TensorBoard
    callback_tensorboard(log_dir = "data/logs")
  )
)

plot(hist)


##------------------------------
## library
##------------------------------

library(xgboost)

##------------------------------
## initialize
##------------------------------

result_all <- NULL

set.seed(1000)

for(i in 1:300){

	cat("\ncount: ", i, "-----\n")

	##------------------------------
	## params
	##------------------------------

	myparam_colsample_bytree <- runif(1, 0.5, 0.99)
	myparam_subsample <- runif(1, 0.7, 0.99)
	myparam_eta <- runif(1, 0.005, 0.05)
	myparam_max_depth <- sample(4:8, 1)
	myparam_max_delta_step <- sample(0:3, 1)
	myparam_base_score <- runif(1, 0.05, 0.5)

	##------------------------------
	## read data
	##------------------------------

	## main table ----------

	train <- read.csv("../../input/train.csv", stringsAsFactors = F)
	test <- read.csv("../../input/test.csv", stringsAsFactors = F)

	## name features ----------

	train_name_features <- read.csv("../../add_features/name_feature_train.csv", stringsAsFactors = F)
	test_name_features <- read.csv("../../add_features/name_feature_test.csv", stringsAsFactors = F)

	train <- merge(train, train_name_features, by = "ID")
	test <- merge(test, test_name_features, by = "ID")

	## fill na ----------

	train[is.na(train)] <- -999999
	test[is.na(test)] <- -999999

	#Building the model
	set.seed(1000 + i)
	param <- list(objective = "binary:logistic",
					booster = "gbtree",
					eval_metric = "auc",
					colsample_bytree = myparam_colsample_bytree,
					subsample = myparam_subsample,
					eta = myparam_eta,
					max.depth = myparam_max_depth,
					max_delta_step = myparam_max_delta_step,
					base_score = myparam_base_score)

	y <- as.numeric(train$train_target)

	train_y <- train$train_target
	train_x <- train
	train_x$train_target <- NULL

	test_id <- test$ID

	train_x$ID <- NULL
	test$ID <- NULL

	dtrain <- xgb.DMatrix(data.matrix(train_x), label = train_y)

	model_cv <- xgb.cv(param = param,
						data = dtrain,
						nrounds = 100000,
						nfold = 10,
						early.stop.round = 100,
						print.every.n = 100L)

	best_score <- max(model_cv$test.auc.mean)
	cat("\nbest_score: ", best_score, "\n")
	best_itr <- which.max(model_cv$test.auc.mean)

	result_new <- data.frame(ID = i,
		myparam_colsample_bytree = myparam_colsample_bytree,
		myparam_subsample = myparam_subsample,
		myparam_eta = myparam_eta,
		myparam_max_depth = myparam_max_depth,
		myparam_max_delta_step = myparam_max_delta_step,
		myparam_base_score = myparam_base_score,
		best_itr = as.integer(best_itr * 1.1),
		best_score = best_score)

	print(result_new)

	prj_name <- "02_xgb"

	result_all <- rbind(result_all, result_new)
	write.table(result_all, "result_all.csv", sep = ",", row.names = FALSE)

	model <- xgb.train(data = dtrain, params = param, nrounds = best_itr)

	imp <- xgb.importance(feature_names = colnames(train_x), model = model)

	dtest <- xgb.DMatrix(data.matrix(test))

	## predict -----
	submission <- predict(model, dtest)
	submission <- data.frame(ID = test_id, TARGET = submission)

	dir.create(paste0("../../submission/", prj_name, "/"), showWarnings = FALSE, recursive = TRUE)
	filename <- paste0("../../submission/", prj_name, "/", prj_name, "_itr", i, "_valid", sprintf("%.4f", best_score), ".csv")
	write.table(submission, filename, sep = ",", row.names = FALSE)
}


get_contrast_matrix = function(
	data
	, formula
	, contrast_kind = NULL
){
	if (inherits(data, "tbl_df")) {
		data = as.data.frame(data)
	}
	vars = attr(terms(formula),'term.labels')
	vars = vars[!grepl(':',vars)]
	if(length(vars)==1){
		data = data.frame(data[,vars])
		names(data) = vars
	}else{
		data = data[,vars]
	}
	vars_to_rename = NULL
	for(i in vars){
		if(is.character(data[,i])){
			data[,i] = factor(data[,i])
		}
		if( is.factor(data[,i])){
			if(length(levels(data[,i]))==2){
				vars_to_rename = c(vars_to_rename,i)
			}
			if(!is.null(contrast_kind) ){
				contrasts(data[,i]) = contrast_kind
			}
		}
	}
	mm = model.matrix(data=data,object=formula)
	dimnames(mm)[[2]][dimnames(mm)[[2]]=='(Intercept)'] = '(I)'
	for(i in vars_to_rename){
		dimnames(mm)[[2]] = gsub(paste0(i,1),i,dimnames(mm)[[2]])
	}
	attr(mm,'formula') = formula
	attr(mm,'data') = data
	return(mm)
}


data <- read.csv("all_results.csv", header=FALSE, sep="\t")
names <- c("One Point", "Counter-based", "Zero-lengths", "Map of ones")

pdf("plot-nvar6.pdf")
dat <- c(table(data$V1), table(data$V2), table(data$V3), table(data$V4))
d <- c(dat[1:6], 0, dat[7])
names(d) <- c(names(dat)[1:6], names(dat)[1], names(dat)[7])
dat <- d
xx  <- barplot(dat, beside=TRUE, ylim=c(0,52), ylab="Frequency", width=0.85, col=c("dark red", "dark blue"), xaxt = "n")
text(x = xx, y = 1, label = labels(dat), col="white")
text(x = xx, y = dat + 1, label = dat)
lpos = c((xx[1] + xx[2])/2, (xx[3] + xx[4])/2, (xx[5] + xx[6])/2, (xx[7] + xx[8])/2)
text(x = lpos, y = -2, label=names, xpd=NA)
dev.off()
pdf("plot-nvar7.pdf")
dat <- c(table(data$V5), table(data$V6), table(data$V7), table(data$V8))
d <- c(dat[1:6], 0, dat[7])
names(d) <- c(names(dat)[1:6], names(dat)[1], names(dat)[7])
dat <- d
xx  <- barplot(dat, beside=TRUE, ylim=c(0,52), ylab="Frequency", width=0.85, col=c("dark red", "dark blue"), xaxt = "n")
text(x = xx, y = 1, label = labels(dat), col="white")
text(x = xx, y = dat + 1, label = dat)
lpos = c((xx[1] + xx[2])/2, (xx[3] + xx[4])/2, (xx[5] + xx[6])/2, (xx[7] + xx[8])/2)
text(x = lpos, y = -2, label=names, xpd=NA)
dev.off()
pdf("plot-nvar8.pdf")
dat <- c(table(data$V9), table(data$V10), table(data$V11), table(data$V12))
d <- c(dat[1:6], 0, dat[7])
names(d) <- c(names(dat)[1:6], names(dat)[1], names(dat)[7])
dat <- d
xx  <- barplot(dat, beside=TRUE, ylim=c(0,52), ylab="Frequency", width=0.85, col=c("dark red", "dark blue"), xaxt = "n")
text(x = xx, y = 1, label = labels(dat), col="white")
text(x = xx, y = dat + 1, label = dat)
lpos = c((xx[1] + xx[2])/2, (xx[3] + xx[4])/2, (xx[5] + xx[6])/2, (xx[7] + xx[8])/2)
text(x = lpos, y = -2, label=names, xpd=NA)
dev.off()

r <- rep(0, 18)
r[1] <- wilcox.test(data$V1, data$V2)$p.value
r[2] <- wilcox.test(data$V1, data$V3)$p.value
r[3] <- wilcox.test(data$V1, data$V4)$p.value
r[4] <- wilcox.test(data$V2, data$V3)$p.value
r[5] <- wilcox.test(data$V2, data$V4)$p.value
r[6] <- wilcox.test(data$V3, data$V4)$p.value

r[7] <- wilcox.test(data$V5, data$V6)$p.value
r[8] <- wilcox.test(data$V5, data$V7)$p.value
r[9] <- wilcox.test(data$V5, data$V8)$p.value
r[10] <- wilcox.test(data$V6, data$V7)$p.value
r[11] <- wilcox.test(data$V6, data$V8)$p.value
r[12] <- wilcox.test(data$V7, data$V8)$p.value

r[13] <- wilcox.test(data$V9, data$V10)$p.value
r[14] <- wilcox.test(data$V9, data$V11)$p.value
r[15] <- wilcox.test(data$V9, data$V12)$p.value
r[16] <- wilcox.test(data$V10, data$V11)$p.value
r[17] <- wilcox.test(data$V10, data$V12)$p.value
r[18] <- wilcox.test(data$V11, data$V12)$p.value

write.table(r, "pvalues.csv", sep="\t", col.names=FALSE, row.names=FALSE)


#' @param bw The smoothing bandwidth to be used.
#'   If numeric, the standard deviation of the smoothing kernel.
#'   If character, a rule to choose the bandwidth, as listed in
#'   [stats::bw.nrd()].
#' @param adjust A multiplicate bandwidth adjustment. This makes it possible
#'    to adjust the bandwidth while still using the a bandwidth estimator.
#'    For example, `adjust = 1/2` means use half of the default bandwidth.
#' @param kernel Kernel. See list of available kernels in [density()].
#' @param n number of equally spaced points at which the density is to be
#'   estimated, should be a power of two, see [density()] for
#'   details
#' @param trim If `FALSE`, the default, each density is computed on the
#'   full range of the data. If `TRUE`, each density is computed over the
#'   range of that group: this typically means the estimated x values will
#'   not line-up, and hence you won't be able to stack density values.
#'   This parameter only matters if you are displaying multiple densities in
#'   one plot or if you are manually adjusting the scale limits.
#' @section Computed variables:
#' \describe{
#'   \item{density}{density estimate}
#'   \item{count}{density * number of points - useful for stacked density
#'      plots}
#'   \item{scaled}{density estimate, scaled to maximum of 1}
#'   \item{n}{number of points}
#'   \item{ndensity}{alias for `scaled`, to mirror the syntax of
#'    [`stat_bin()`]}
#' }
#' @export
#' @rdname geom_density
stat_density <- function(mapping = NULL, data = NULL,
                         geom = "area", position = "stack",
                         ...,
                         bw = "nrd0",
                         adjust = 1,
                         kernel = "gaussian",
                         n = 512,
                         trim = FALSE,
                         na.rm = FALSE,
                         orientation = NA,
                         show.legend = NA,
                         inherit.aes = TRUE) {

  layer(
    data = data,
    mapping = mapping,
    stat = StatDensity,
    geom = geom,
    position = position,
    show.legend = show.legend,
    inherit.aes = inherit.aes,
    params = list2(
      bw = bw,
      adjust = adjust,
      kernel = kernel,
      n = n,
      trim = trim,
      na.rm = na.rm,
      orientation = orientation,
      ...
    )
  )
}

#' @rdname ggplot2-ggproto
#' @format NULL
#' @usage NULL
#' @export
StatDensity <- ggproto("StatDensity", Stat,
  required_aes = "x|y",

  default_aes = aes(x = after_stat(density), y = after_stat(density), fill = NA, weight = NULL),

  setup_params = function(self, data, params) {
    params$flipped_aes <- has_flipped_aes(data, params, main_is_orthogonal = FALSE, main_is_continuous = TRUE)

    has_x <- !(is.null(data$x) && is.null(params$x))
    has_y <- !(is.null(data$y) && is.null(params$y))
    if (!has_x && !has_y) {
      cli::cli_abort("{.fn {snake_class(self)}} requires an {.field x} or {.field y} aesthetic.")
    }

    params
  },

  extra_params = c("na.rm", "orientation"),

  compute_group = function(data, scales, bw = "nrd0", adjust = 1, kernel = "gaussian",
                           n = 512, trim = FALSE, na.rm = FALSE, flipped_aes = FALSE) {
    data <- flip_data(data, flipped_aes)
    if (trim) {
      range <- range(data$x, na.rm = TRUE)
    } else {
      range <- scales[[flipped_names(flipped_aes)$x]]$dimension()
    }

    density <- compute_density(data$x, data$weight, from = range[1],
      to = range[2], bw = bw, adjust = adjust, kernel = kernel, n = n)
    density$flipped_aes <- flipped_aes
    flip_data(density, flipped_aes)
  }

)

compute_density <- function(x, w, from, to, bw = "nrd0", adjust = 1,
                            kernel = "gaussian", n = 512) {
  nx <- length(x)
  if (is.null(w)) {
    w <- rep(1 / nx, nx)
  } else {
    w <- w / sum(w)
  }

  # if less than 2 points return data frame of NAs and a warning
  if (nx < 2) {
    cli::cli_warn("Groups with fewer than two data points have been dropped.")
    return(new_data_frame(list(
      x = NA_real_,
      density = NA_real_,
      scaled = NA_real_,
      ndensity = NA_real_,
      count = NA_real_,
      n = NA_integer_
    ), n = 1))
  }

  dens <- stats::density(x, weights = w, bw = bw, adjust = adjust,
    kernel = kernel, n = n, from = from, to = to)

  new_data_frame(list(
    x = dens$x,
    density = dens$y,
    scaled =  dens$y / max(dens$y, na.rm = TRUE),
    ndensity = dens$y / max(dens$y, na.rm = TRUE),
    count =   dens$y * nx,
    n = nx
  ), n = length(dens$x))
}


context('mini via har; st tunneling boxplots')
test_that("mini_constr", {
	har_n <- 1e3

    st_constr_str <- force_cos_ramp_constraint(H_matrix_mini, bounds_tuple_of_numeric_mini, 5.33, .2187, .2187, n_task_values = 10, cycles_per_second=10,eliminate = FALSE)
    res <- st_constr_str$nonredundant_constr %>% eliminate_redundant
    mini_points <- res %>% pb_har_sample(har_n, mc.cores=8, eliminate=FALSE)
    print(summary(mini_points))
    profvis(expr={tall_df <- mini_points %>% trajectory_har_df_melt(3)})
    p_st1 <- ggplot(tall_df, aes(task_index, col=muscle)) + geom_boxplot(aes(x="", activation, group=task_index)) + facet_wrap(~muscle) + ggtitle("ST2") + theme_classic()

    st_constr_str <- force_cos_ramp_constraint(H_matrix_mini, bounds_tuple_of_numeric_mini, 5.33, .25, .25, n_task_values = 10, cycles_per_second=10,eliminate = FALSE)
    res <- st_constr_str$nonredundant_constr %>% eliminate_redundant
    mini_points <- res %>% pb_har_sample(har_n, mc.cores=8, eliminate=FALSE)
    print(summary(mini_points))
    profvis(expr={tall_df <- mini_points %>% trajectory_har_df_melt(3)})
    p_st2 <- ggplot(tall_df, aes(task_index, col=muscle)) + geom_boxplot(aes(x="", activation, group=task_index)) + facet_wrap(~muscle) + ggtitle("ST2") + theme_classic()

    st_constr_str <- force_cos_ramp_constraint(H_matrix_mini, bounds_tuple_of_numeric_mini, 5.33, 1.0, 1.0, n_task_values = 10, cycles_per_second=10,eliminate = FALSE)
    res <- st_constr_str$nonredundant_constr %>% eliminate_redundant
    mini_points <- res %>% pb_har_sample(har_n, mc.cores=8, eliminate=FALSE)
    print(summary(mini_points))
    profvis(expr={tall_df <- mini_points %>% trajectory_har_df_melt(3)})
    p_degenerate <- ggplot(tall_df, aes(task_index, col=muscle)) + geom_boxplot(aes(x="", activation, group=task_index)) + facet_wrap(~muscle) + ggtitle("p_degenerate") + theme_classic()

    p <- arrangeGrob(grobs=list(p_degenerate, p_st2,p_st1), ncol=1)
    ggsave("mini_constr.jpg",p, width=20,height=30)
    browser()
    print(st_constr_str$tasks_and_constraints$tasks$time)

})

test_that('histograms', {
    har_n <- 1e3
    st_constr_str <- force_cos_ramp_constraint(H_matrix_mini, bounds_tuple_of_numeric_mini, 5.33, .2187, .2187, n_task_values = 10, cycles_per_second=10,eliminate = FALSE)
    res <- st_constr_str$nonredundant_constr %>% eliminate_redundant
    mini_points <- res %>% pb_har_sample(har_n, mc.cores=8, eliminate=FALSE)
    print(summary(mini_points))
    tall_df_st <- mini_points %>% trajectory_har_df_melt(3)
    tall_df_st$st <- 1

    st_constr_str <- force_cos_ramp_constraint(H_matrix_mini, bounds_tuple_of_numeric_mini, 5.33, 1.0, 1.0, n_task_values = 10, cycles_per_second=10,eliminate = FALSE)
    res <- st_constr_str$nonredundant_constr %>% eliminate_redundant
    mini_points <- res %>% pb_har_sample(har_n, mc.cores=8, eliminate=FALSE)
    print(summary(mini_points))
    tall_df_no_st <- mini_points %>% trajectory_har_df_melt(3)
    tall_df_no_st$st <- 0

    tall_df<- rbind(tall_df_no_st, tall_df_st)
    tall_df$st <- as.factor(tall_df$st)

    p <- ggplot(tall_df, aes(fill=st)) +  geom_histogram(aes(activation)) + facet_grid(task_index~muscle, space="free")
    p <- p + theme_classic() + xlab("Task Index") + ylab("Number of Trajectories") + ggtitle("ST of .2187 max delta activation per 10ms vs degenerate case")
    p <- p + scale_y_continuous(labels = scales::percent)
    ggplotly(p)

})


deform_snail = function(x,y)
{
 	theta = 3.14159 * (1-x)
	expand = 0.4 + x*1.8
	yoff = y - 0.5

	xtag = cos(theta) + yoff*expand*cos(theta)
	ytag = sin(theta) + yoff*expand*sin(theta)
	return(list(xtag, ytag))
}

deform_boom = function(x,y,rmin=0)
{
	r = rmin+(x)*(1-rmin)
	xc = as.character(x)
	normy = rank(rank(x)*max(y,na.rm=T)+y)
#	normy = y
	min_y = tapply(normy,xc,min, na.rm=T)
	max_y = tapply(normy,xc,max, na.rm=T)
	range_y = max_y-min_y+8
	range_y[range_y==0] = 1
	theta = (normy-min_y[xc])/range_y[xc]*2*3.14159

	xtag = r*cos(theta)
	ytag = r*sin(theta)
	return(list(xtag, ytag))
}

mctnetwork_mc_rank_from_color_ord = function(mct_id, colors_ordered = NULL)
{
	mct = scdb_mctnetwork(mct_id)
	if(is.null(mct)) {
		stop("cannot find mctnet object ", mct_id, " when trying to plot net flows")
	}
	mc = scdb_mc(mct@mc_id)
	mc_mean_age = apply(mct@mc_t, 1, function(x) {return(mean(x*(1:length(x))/sum(x))) })
	col_to_rank = c(1:length(colors_ordered))
	names(col_to_rank) = colors_ordered

	mc_rank = 1000*col_to_rank[mc@colors] + mc_mean_age
	mc_rank = rank(mc_rank)
	names(mc_rank) = as.character(1:length(mc_rank))

	mc_flows = mctnetwork_get_flow_mat(mct, -1)
	diag(mc_flows) = 0
	mc_flow_fore = mc_flows/rowSums(mc_flows)
	mc_flow_back = t(mc_flows)/colSums(mc_flows)

	mc_rank1 = mc_rank

#cluster flow graph
#rank clusters by mean rank
#rank mc by membership + time
if(0) {
	for(i in 1:20) {
		rank_fore = mc_flow_fore %*% mc_rank1
		rank_back = mc_flow_back %*% mc_rank1

		dfore = rank_fore-mc_rank1
		dback = rank_back-mc_rank1

		f = sign(dfore) == sign(dback)
		f[is.na(f)] = F
#		message("iter ", i, " sign consist on " , sum(f))
		dlt = sign(dfore) * pmin(abs(dfore), abs(dback))
		dlt[!f] = 0
#		message("max dlt ", paste(tail(sort(dlt),5)," "))
		mc_rank1 = rank(mc_rank1 + dlt*0.5)
		names(mc_rank1) = as.character(1:length(mc_rank))
	}
}
#plot(sign(dfore)*log2(abs(dfore)), sign(dback)*log2(abs(dback)), pch=19, col=mc@colors, cex=1.5)
	return(mc_rank1)
}
#color_ord = read.table("config/color_cell_type_order_flow.txt", h=T, sep="\t",stringsAsFactors = F)

mctnetwork_plot_net = function(mct_id, fn,
						mc_ord = NULL, colors_ordered = NULL,
						propogate=NULL,
						mc_t_score = NULL,
						edge_w_scale=5e-4,
						flow_thresh = 1e-4,
						w = 2000,h = 2000,
						mc_cex = 0.5,
						dx_back = 0.15, dy_ext = 0.4,
						sigmoid_edge = F, grad_col_edge = F,
						plot_mc_ids = F,miss_color_thresh = 0.5,
						func_deform=NULL,
						score_shades = colorRampPalette(c("lightgray", "gray", "darkgray", "lightpink", "pink", "red", "darkred"))(1000))
{
	if(!is.null(propogate) | !is.null(mc_t_score)) {
		dx_back = 0
		dy_ext = 0
	}

	mct = scdb_mctnetwork(mct_id)
	if(is.null(mct)) {
		stop("cannot find mctnet object ", mct_id, " when trying to plot net flows")
	}
	net= mct@network
	mc = scdb_mc(mct@mc_id)
	if(is.null(mc)) {
		stop("cannot find mc object ", mct@mc_id, " matching the mc id in the mctnetwork object! db mismatch? recreate objects?")
	}
	if(is.null(mct@edge_flows) | sum(mct@edge_flows)==0) {
		stop("flows seems not to be initialized in mct id ", mct_id, " maybe rerun the mincost algorithm?")
	}
	names(mc@colors) = as.character(1:length(mc@colors))

#color_ord = read.table("config/atlas_type_order.txt", h=T, sep="\t")
#order MCs by type, mean age
  if(is.null(mc_ord)) {
	 if(is.null(colors_ordered)) {
			stop("specify either mc_ord or color ord when plotting mctnet network")
	 }
	 mc_rank = mctnetwork_mc_rank_from_color_ord(mct_id, colors_ordered)
  } else {
    mc_rank = rep(-1,length(mc_ord))
    mc_rank[mc_ord] = c(1:length(mc_ord))
    names(mc_rank) = as.character(1:length(mc_rank))
  }

  mc_rank["-2"] = 0
  mc_rank["-1"] = length(mc_rank)/2

  #add growth mc

	f= net$flow > flow_thresh
	nn = net[f,]
	x1 = nn$time1
	x2 = nn$time2
	y1 = as.numeric(mc_rank[as.character(nn$mc1)])
	y2 = as.numeric(mc_rank[as.character(nn$mc2)])

	x1 = ifelse(nn$type1 == "growth", x1 + 0.3, x1)
	x2 = ifelse(nn$type2 == "growth", x2 + 0.3, x2)
	x1 = ifelse(nn$type1 == "norm_b" | nn$type1 == "extend_b",x1-dx_back,x1)
	x2 = ifelse(nn$type2 == "norm_b" | nn$type2 == "extend_b",x2-dx_back,x2)
	y1 = ifelse(nn$type1 == "src", max(y1)/2, y1)
	y2 = ifelse(nn$type2 == "sink", max(y2)/2, y2)
	y2 = ifelse(nn$type2 == "sink", NA, y2)
	y1 = ifelse(nn$type1 == "growth", y2+2.5, y1)
	y2 = ifelse(nn$type2 == "growth", y1+2.5, y2)
	y1 = ifelse(nn$type1 == "extend_b" | nn$type1 == "extend_f",y1+dy_ext, y1)
	y2 = ifelse(nn$type2 == "extend_f" | nn$type2 == "extend_b",y2+dy_ext, y2)

	if(!is.null(func_deform)) {
		x1 = ifelse(nn$type1 == "growth", NA, x1)
		x2 = ifelse(nn$type2 == "growth", NA, x2)
		y1 = ifelse(nn$type1 == "growth", NA, y1)
		y2 = ifelse(nn$type2 == "growth", NA, y2)
		min_x = min(c(x1,x2),na.rm=T)
		min_y = min(c(y1,y2),na.rm=T)
		range_x = (max(c(x1,x2),na.rm=T)-min_x)
		range_y = (max(c(y1,y2),na.rm=T)-min_y)
		ax = c((x1-min_x)/range_x, (x2-min_x)/range_x)
		ay = c((y1-min_y)/range_y, (y2-min_y)/range_y)
		atag = func_deform(ax, ay)
		n1 = length(x1)
		n = length(ax)
		x1 = atag[[1]][1:n1]
		x2 = atag[[1]][(n1+1):n]
		y1 = atag[[2]][1:n1]
		y2 = atag[[2]][(n1+1):n]

if(0) {
		xy1 = func_deform((x1-min_x)/range_x, (y1-min_y)/range_y)
		xy2 = func_deform((x2-min_x)/range_x, (y2-min_y)/range_y)
		x1 = xy1[[1]]
		x2 = xy2[[1]]
		y1 = xy1[[2]]
		y2 = xy2[[2]]
}
	}

	nn$mc1 = ifelse(nn$type1 == "src", nn$mc2, nn$mc1)

	png(fn, width = w,height = h)
	f_overflow = nn$type2=="extend_f" & nn$cost > 100
	f_underflow = nn$type2 == "norm_f" & nn$cost < -100
#  nn$flow/(1e-8 + nn$capacity) < miss_color_thresh
	if(is.null(propogate) & is.null(mc_t_score)) {
		plot(c(x1,x2), c(y1,y2), pch=19, col=mc@colors[c(nn$mc1,nn$mc2)],cex=mc_cex)
		mc_rgb = col2rgb(mc@colors)/256
		f = nn$mc1>0 & nn$mc2 > 0
		m1 = as.numeric(nn$mc1[f])
		m2 = as.numeric(nn$mc2[f])
		seg_df = data.frame(x1 = x1[f], y1=y1[f], dx=x2[f]-x1[f], dy=y2[f]-y1[f],
									r1 = mc_rgb["red",m1],
									r2 = mc_rgb["red",m2],
									g1 = mc_rgb["green",m1],
									g2 = mc_rgb["green",m2],
									b1 = mc_rgb["blue",m1],
									b2 = mc_rgb["blue",m2])

		for(alpha in seq(0,0.98,0.02)) {
			beta = alpha
			beta5 = alpha+0.02
			if(sigmoid_edge) {
			beta = plogis(alpha,loc=0.5,scale=0.1)
			beta5 = plogis(alpha+0.02,loc=0.5,scale=0.1)
			}
			sx1 = seg_df$x1+alpha*seg_df$dx
			sx2 = seg_df$x1+(alpha+0.02)*seg_df$dx
			sy1 = seg_df$y1+beta*seg_df$dy
			sy2 = seg_df$y1+beta5*seg_df$dy
			alpha_col = ifelse(grad_col_edge, alpha,0)
			rgb_r = seg_df$r2*alpha_col+seg_df$r1*(1-alpha_col)
			rgb_g = seg_df$g2*alpha_col+seg_df$g1*(1-alpha_col)
			rgb_b = seg_df$b2*alpha_col+seg_df$b1*(1-alpha_col)
			cols = rgb(rgb_r, rgb_g, rgb_b)
			segments(sx1, sy1, sx2, sy2,
				col=ifelse(nn$type2=="growth" | nn$type1=="source" | nn$type2=="sink", "gray", cols),
				lwd=pmin(nn$flow/edge_w_scale, 10))
		}
#		segments(x1,y1,x2,y2,
#				col=ifelse(nn$type2=="growth", "black", mc@colors[nn$mc1]),
#				lwd=pmin(nn$flow/edge_w_scale, 10))
		f = f_overflow; segments(x1[f],y1[f],x2[f],y2[f], col="red",
									lwd=pmin(nn$flow[f]/edge_w_scale, 10))
		f = f_underflow; segments(x1[f],y1[f],x2[f],y2[f], col="blue",
	         					lwd=pmin((nn$capacity[f] - nn$flow[f])/edge_w_scale,10))
#		points(c(x1,x2), c(y1,y2), pch=19, col=mc@colors[c(nn$mc1,nn$mc2)],cex=1)
	} else if(!is.null(mc_t_score)) {
		plot(c(x1,x2), c(y1,y2), pch=19, col=mc@colors[c(nn$mc1,nn$mc2)],cex=mc_cex)
		mc_t_score = pmax(mc_t_score, quantile(mc_t_score,0.03))
		mc_t_score = pmin(mc_t_score, quantile(mc_t_score,0.97))
		mc_t_score = mc_t_score-min(mc_t_score)
		mc_t_score = mc_t_score/max(mc_t_score)
		mc_t_score = floor(1+999*mc_t_score)
		f = nn$mc1>0 & nn$mc2>0 & nn$time1>0
		max_mc = nrow(mc_t_score)
		m1 = as.numeric(nn$mc1[f])
		m2 = as.numeric(nn$mc2[f])
		score1 = rep(1, nrow(nn))
		score2 = rep(1, nrow(nn))
		score1[f] = mc_t_score[m1+(nn[f,"time1"]-1)*max_mc]
		score2[f] = mc_t_score[m2+(nn[f,"time2"]-1)*max_mc]

		seg_df = data.frame(x1 = x1, y1=y1, dx=x2-x1, dy=y2-y1,
														score1= score1, dscore=score2-score1)

		for(alpha in seq(0,0.95,0.05)) {
			x1 = seg_df$x1+alpha*seg_df$dx
			x2 = seg_df$x1+(alpha+0.05)*seg_df$dx
			y1 = seg_df$y1+alpha*seg_df$dy
			y2 = seg_df$y1+(alpha+0.05)*seg_df$dy
			cols = score_shades[floor(seg_df$score1 + (alpha+0.025)*seg_df$dscore)]
			segments(x1, y1, x2, y2,
				col=ifelse(nn$type2=="growth" | nn$type1=="source" | nn$type2=="sink", "gray", cols),
				lwd=pmin(nn$flow/edge_w_scale, 10))
		}
		rect(seg_df$x1-0.12,seg_df$y1-0.5, seg_df$x1+0.12, seg_df$y1+0.5,
					col = mc@colors[nn$mc1], border=NA)
		rect(seg_df$x2-0.12,seg_df$y2-0.5, seg_df$x2+0.12, seg_df$y2+0.5,
					col = mc@colors[nn$mc2], border=NA)
	} else {
		plot(c(x1,x2), c(y1,y2), pch=19, col=mc@colors[c(nn$mc1,nn$mc2)],cex=mc_cex)
		max_time = length(propogate)
		m1 = as.numeric(nn$mc1)
		m2 = as.numeric(nn$mc2)
		max_m = ncol(propogate[[1]])
		prop_flow = rep(0, nrow(nn))
		for(t in 1:max_time) {
			f = (nn$time1 == t) & nn$mc1>0 & nn$mc2>0
			prop_flow[f] = propogate[[t]][m1[f]+max_m*(m2[f]-1)]
		}
		segments(x1,y1,x2,y2,
				col=ifelse(nn$type2=="growth", "black", mc@colors[nn$mc1]),
				lwd=pmin(prop_flow/edge_w_scale, 10))
		points(c(x1,x2), c(y1,y2), pch=19, col=mc@colors[c(nn$mc1,nn$mc2)],cex=m_cex)
	}

	if(plot_mc_ids) {
		f1 = nn$type1!="growth"
		text(x1[f1]-0.2,y1[f1], labels = nn$mc1[f1], cex=1)
#	  text(c(x1[f1],x2[f2]),c(y1[f1],y2[f2]),labels = c(nn$mc1[f1],nn$mc2[f2]), cex=1)
	}

	dev.off()
}

mctnetwork_plot_propagation = function(mct_id, time, p_anchor, fn,
						mc_ord = NULL, colors_ordered = NULL,
						edge_w_scale=5e-4,
						w = 2000,h = 2000, mc_cex=1)
{
	mct = scdb_mctnetwork(mct_id)
	if(is.null(mct)) {
		stop("cannot find mctnet object ", mct_id, " when trying to plot net flows anchors")
	}
	probs = mctnetwork_propogate_from_t(mct, time, p_anchor)
	mctnetwork_plot_net(mct_id, fn=fn,
					propogate = probs$step_m,
					mc_ord = mc_ord, colors_ordered = colors_ordered,
					edge_w_scale = edge_w_scale,
					w = w, h = h, mc_cex = mc_cex)
}


# ----------------------------
#  App Title: LCO CI Generator
#     Author: Jimmy Doi
# ----------------------------

library(shiny)

shinyUI(fluidPage(
    tags$head(tags$link(rel = "icon", type = "image/x-icon", href =
    "https://webresource.its.calpoly.edu/cpwebtemplate/5.0.1/common/images_html/favicon.ico")),

  tags$title("LCO Confidence Interval Generator"),
  titlePanel("LCO Confidence Interval Generator"),

  div("Note: Please adjust width of browser if only one column is visible.",
    style = "font-size: 9pt;color:teal"),br(),br(),

  sidebarPanel(

      sliderInput("level",
                label = h5("Confidence Level %:"),
                min = 80, max = 99, value = 95, step=1),br(),

      sliderInput("size",
                  label = h5("Sample Size:"),
                  min = 1, max = 200, value = 25),br(),

      selectInput("dpsize",
                  label = h5("Decimal Place Accuracy:"),
                  choices = c("2nd", "3rd", "4th"),
                  selected = "2nd"),

      div("At 4th decimal place accuracy computation time may require up to
          25 seconds.", style = "font-size: 9.5pt;color:teal",align="right"),
      br(), br(),

      div(submitButton("Submit"),align="right"), br(), br(), br(), br(), br(),

      div("Shiny app by",
          a(href="http://statweb.calpoly.edu/jdoi/",target="_blank",
            "Jimmy Doi"),align="right", style = "font-size: 8pt"),

      div("Base R code by",
          a(href="http://statweb.calpoly.edu/jdoi/",target="_blank",
            "Jimmy Doi"),align="right", style = "font-size: 8pt"),

      div("Shiny source files:",
          a(href="https://gist.github.com/calpolystat/d896c5848934484181be",
            target="_blank","GitHub Gist"),align="right", style = "font-size: 8pt"),

      div(a(href="http://www.statistics.calpoly.edu/shiny",target="_blank",
            "Cal Poly Statistics Dept Shiny Series"),align="right", style = "font-size: 8pt")
    ),

  mainPanel(
    p("Details on the Length/Coverage Optimal (LCO) confidence interval for
       the binomial proportion can be found in the following journal
       article:"),

    #     tags$blockquote("Schilling, M., and Doi, J. (2014) 'A Coverage Probability
    #        Approach to Finding an Optimal Binomial Confidence Procedure'",
    #        em("The American Statistician"),", 68, 133-145. ",
    #        a(href="http://amstat.tandfonline.com/doi/abs/10.1080/00031305.2014.899274#.UyNr7oWuomg",
    #        target="_blank", "(Online access)")),

    div("Schilling, M., and Doi, J. (2014) 'A Coverage Probability Approach to Finding an Optimal
        Binomial Confidence Procedure'",
        em("The American Statistician"),", 68(3), 133--145",
        a(href="http://amstat.tandfonline.com/doi/abs/10.1080/00031305.2014.899274#.UyNr7oWuomg",
          target="_blank", "(Online access)"),style="padding-left: 20px;
        display:block; border-left: 5px solid #faebbc;margin-left:0px"),br(),

    p("The ", a(href="http://www.calpoly.edu/~jdoi/LCO/", target="_blank", "LCO website"),
      "contains the R code for the CI algorithm and a full listing of LCO CIs
      (at 5 decimal places), for", em("n"), " = 1, 2, ..., 100 at the
      90, 95, and 99% levels."),

    HTML("<hr style='height: 2px; color: #de7008; background-color: #df7109; border: none;'>"),

    textOutput("textlevel"),
    textOutput("textsize"),
    textOutput("textdp"),
    br(),
    verbatimTextOutput("LCOresults")
    )
  )
)


context("MCMC")

test_that("Error checks", {

  f <- function(i) {}
  expect_error(
    MCMC(f, initial = 1, nsteps = 100, burnin = 100),
    "burnin"
  )

  expect_error(
    MCMC(f, initial = 1, nsteps = 100, burnin = 0, thin = -1),
    "thin"
  )

  expect_error(
    MCMC(f, initial = 1, nsteps = 100, burnin = 0, thin = 100),
    "thin"
  )

  f <- function(i) {NaN}
  expect_error(
    MCMC(f, initial = 1, nsteps = 100, burnin = 10),
    "undefined"
  )

})

# ------------------------------------------------------------------------------
test_that("Reasonable values", {

  # Simulating data
  set.seed(981)

  D <- rnorm(1000, 0)

  # Preparing function
  fun <- function(x) {
    res <- log(dnorm(D, x))
    if (any(is.infinite(res) | is.nan(res)))
      return(.Machine$double.xmin)
    sum(res)
  }

  # Running the algorithm and checking expectation
  set.seed(111)
  ans0 <- suppressWarnings(
    MCMC(fun, initial = 1, nsteps = 5e3, burnin = 500,
         kernel = kernel_normal(scale = 1))
  )
  expect_equal(mean(ans0), mean(D), tolerance = 0.05, scale = 1)

})

# ------------------------------------------------------------------------------
test_that("Reasonable values after changing the scale", {

  # Simulating data
  set.seed(981)

  D <- rnorm(1000, 0)

  # Preparing function
  fun <- function(x) {
    res <- log(dnorm(D, x))
    if (any(is.infinite(res) | is.nan(res)))
      return(.Machine$double.xmin)
    sum(res)
  }

  # Running the algorithm and checking expectation
  set.seed(111)
  ans0 <- suppressWarnings(
    MCMC(fun, initial = 1, nsteps = 5e3, burnin = 500,
         kernel = kernel_normal(scale = 2))
  )
  expect_equal(mean(ans0), mean(D), tolerance = 0.05, scale = 1)

})

# ------------------------------------------------------------------------------
test_that("Multiple chains", {
  # Simulating data
  set.seed(981)

  D <- rnorm(1000, 0)

  # Preparing function
  fun <- function(x, D) {
    res <- log(dnorm(D, x))
    if (any(is.infinite(res) | is.nan(res)))
      return(.Machine$double.xmin)
    sum(res)
  }

  # Running the algorithm and checking expectation
  ans0 <- suppressWarnings(
    MCMC(fun, initial = 1, nsteps = 5e3, burnin = 500,
         kernel = kernel_normal(scale = 1),
         D=D, nchains=2)
  )

  ans1 <- suppressWarnings(
    MCMC(fun, initial = 1, nsteps = 5e3, burnin = 500,
         kernel = kernel_normal(scale = 1),
         D=D, nchains=2, multicore = TRUE)
  )

  expect_equal(sapply(ans0, mean), rep(mean(D),2), tolerance = 0.1, scale = 1)
  expect_equal(sapply(ans1, mean), rep(mean(D),2), tolerance = 0.1, scale = 1)
})

# ------------------------------------------------------------------------------
test_that("Repeating the chains in parallel", {
  # Simulating data
  set.seed(981)

  D <- rnorm(500, 0)

  # Preparing function
  fun <- function(x, D) {
    res <- log(dnorm(D, x))
    if (any(is.infinite(res) | is.nan(res)))
      return(.Machine$double.xmin)
    sum(res)
  }

  # Running the algorithm and checking expectation
  set.seed(1)
  ans0 <- suppressWarnings(
    MCMC(fun, initial = 1, nsteps = 200, burnin = 0,
         kernel = kernel_normal(scale = 1),
         nchains=2, D=D)
  )

  set.seed(1)
  ans1 <- suppressWarnings(
    MCMC(fun, initial = 1, nsteps = 200, burnin = 0,
         kernel = kernel_normal(scale = 1),
         nchains=2, D=D)
  )

  expect_equal(ans0, ans1)

})

# ------------------------------------------------------------------------------
test_that("Fixed parameters", {

  # Simulating data
  set.seed(981)

  D <- rnorm(1000, 0, 2)

  # Preparing function
  fun <- function(x) {
    res <- dnorm(D, x[1], x[2], log = TRUE)
    if (any(is.infinite(res) | is.nan(res)))
      return(.Machine$double.xmin)
    sum(res)
  }

  # Running the algorithm and checking expectation
  ans <- suppressWarnings(
    MCMC(fun, initial = c(1, 2), nsteps = 5e3, burnin = 500,
         kernel = kernel_reflective(
           ub = 3, lb = -3, scale = 1, fixed = c(FALSE, TRUE)
         ))
  )
  expect_true(all(ans[,2] == 2))
  expect_equivalent(colMeans(ans), c(0, 2), tolerance = 0.1, scale = 1)

})

# ------------------------------------------------------------------------------
test_that("Passing the data", {

  # Simulating data
  set.seed(91181)

  D <- rnorm(1000, 0, 2)

  # Serial version -------------------------------------------------------------

  # Preparing function
  fun <- function(x, D.) {
    res <- dnorm(D., x[1], x[2], log = TRUE)
    if (any(is.infinite(res) | is.nan(res)))
      return(.Machine$double.xmin)
    sum(res)
  }

  # Running the algorithm and checking expectation
  ans <- suppressWarnings(
    MCMC(fun,
         initial = c(1, 2),
         nsteps  = 5e3,
         burnin  = 500,
         kernel  = kernel_reflective(ub = 3, lb = c(-3, 0), scale = .25),
         D.      = D
         )
  )

  expect_equivalent(colMeans(ans), c(0, 2), tolerance = 0.1, scale = .2)

  # Parallel version -----------------------------------------------------------

  # Running the algorithm and checking expectation
  ans <- suppressWarnings(
    MCMC(fun,
         initial = c(1, 2),
         nsteps  = 5e3,
         burnin  = 500,
         kernel  = kernel_reflective(ub = 3, lb = c(-3, 0), scale = .25),
         D.      = D,
         nchains = 2L,
         multicore = TRUE
    )
  )

  expect_equivalent(
    colMeans(do.call(rbind, ans)),
    c(0, 2), tolerance = 0.1, scale = .2)

})


########################### BayesKin ###########################
## Code for a comparison of Bayesian models for inverse kinematic problems
## with Maximum likelihood estimation

## Written by: Andy Pohl
## UofC - Faculty of Kinesiology
## June-Dec 2020
## Revision 1: May 2020
################################################################

########################### library.r  #########################
## Contains source functions for BayesKin package - modified for performing
## sensitivity to measurement noise.
################################################################
##### Preliminaries
library(coda)
library(numDeriv)
library(rjags)

# set number of parallel cores
options(mc.cores=4)

########################### Section A  #########################
## Miscellaneous helper functions
################################################################
rt_ls <- function(n, df, mu, a){
  # Generates a random sample from the location scale student-t distribution with mean mu, degrees of freedom
  # df and scale a

  return(rt(n,df)*a + mu)
}

mod_180 = function(angles){
  # Rescales an angle on the (-inf, inf) scale to the interval [-180, 180)
  temp = sapply(angles, function(ang){
    if(abs(ang)<=180){
      return(ang)
    }else if(ang >180){
      remainder = ang-180
      return(-180 + remainder)
    }else if (ang< -180){
      remainder = ang + 180
      return(180 + remainder)
    }
  })
  return(temp)
}
########################### Section B  #########################
## Links, posture and observations
################################################################

gen_link = function(seg.length,
                    plate.center,
                    marker.plate.dim = c(0.1, 0.05)){
  # Creates a rigid link of length seg.length with a marker plate at plate.center
  # with dimensions plate.placement.length*seg.length and markers at each corner
  # of the marker plate.
  plate.loc = c(plate.center,0)

  markers = cbind(c(plate.loc[1]-marker.plate.dim[1]/2, marker.plate.dim[2]/2),
                  c(plate.loc[1]+marker.plate.dim[1]/2, marker.plate.dim[2]/2),
                  c(plate.loc[1]+marker.plate.dim[1]/2, -marker.plate.dim[2]/2),
                  c(plate.loc[1]-marker.plate.dim[1]/2, -marker.plate.dim[2]/2))

  link = list(length = seg.length,
              x = markers)
  return(link)

}

gen_posture = function(links,
                       r,
                       theta,
                       degrees = TRUE){
  # Applies rigid body transformations translation r and rotation by theta to a
  # collection of links.  Note that links must be specified in order (link 1 -
  # link 3) and the length of theta should be the same as the number of links

  if(degrees){
    theta = theta * pi/180
  }

  nlinks = length(links)

  #  Generate rotation matrix for eac link
  Gam = vector('list', nlinks)
  for(i in 1:nlinks){
    Gam[[i]] = matrix(c(cos(theta[i]), sin(theta[i]),
                        -sin(theta[i]), cos(theta[i])), 2, 2)
  }

  # Compute the locations of joint centers for each link in the kinematic chain
  J = vector('list', nlinks+1)
  J[[1]] = matrix(r, 2, 1)
  for(i in 2:(nlinks+1)){
    J[[i]] =  J[[i-1]] + Gam[[i-1]] %*% c(links[[i-1]]$length, 0)
  }

  # Compute actual position of markers alpha in the global coordinate system
  alpha = vector(mode = 'list', length = nlinks)
  for(i in 1:nlinks){
    nmarkers = ncol(links[[i]]$x)
    alpha[[i]] = matrix(NA, 2, nmarkers)
    for(j in 1:nmarkers){
      x_ij = links[[i]]$x[,j]
      alpha[[i]][,j] = J[[i]] + Gam[[i]]%*%x_ij
    }
  }

  # Return posture object (list with origin r, joint position J and expected marker position alpha)
  return(list(r = r, J = J, alpha = alpha))
}

gen_obs = function(posture, sigma){
  # Generates an observation of a given posture subject to random 0 mean gaussain
  # noise with standard deviation sigma
  nlinks = length(posture$alpha)

  y = vector(mode = 'list', length = nlinks)
  for(i in 1:nlinks){
    nmarkers = ncol(links[[i]]$x)
    y[[i]] = matrix(NA, ncol = nmarkers, nrow = 2)
    for(j in 1:nmarkers){
      y[[i]][1, j] = rnorm(1, mean = posture$alpha[[i]][1, j], sd= sigma)
      y[[i]][2, j] = rnorm(1, mean = posture$alpha[[i]][2, j], sd= sigma)
    }
  }
  return(y)
}

plot_system= function(posture, y=NA, ...){
  # Plots the Kinematic chain and observed markers y
  plot(NULL, NULL,
       xlim = c(0, 1), ylim = c(-1, 0.1),
       xlab = 'x', ylab = 'y')
  points(t(do.call(cbind,posture$J)), type = "o", pch = 20,...) # mu_tmp
  orange = rgb(255/255, 140/255, 0, 0.5)
  blue = rgb(0, 0, 1, 0.5)
  points(t(do.call(cbind,posture$alpha)), pch = 20, col = orange)
  if(!is.na(y)){
    points(t(do.call(cbind,y)), pch = 20, col = blue)
  }
}

########################### Section C  #########################
## Maximum likelihood/Least Squares solutions.
################################################################

cost = function(params, y, links){
  # The cost function (equation ... in paper) given a vector
  # params = vector of parameters (rx, ry, theta1, theta2, theta3 ), observations
  # y and known positions of markers within the LCS of each link links.
  nlinks = length(links)
  r.hat = params[1:2]
  theta.hat = params[3:(nlinks+2)]

  obs.hat = gen_posture(links, r = r.hat, theta = theta.hat)
  y.hat = obs.hat$alpha

  cost = 0
  for(i in 1:nlinks){
    nmarkers = ncol(y.hat[[i]])
    for(j in 1:nmarkers){
      diff = y.hat[[i]][,j] - y[[i]][,j]
      cost = cost+ (sqrt(sum(diff*diff)))
    }
  }
  return(cost)
}

costgrad_analytical = function(x, y, links){
  # Generates the analytical gradient of the cost function.  Originally generated
  # via MATLAB and the symbolic toolbox.
  # x is parameter vector (r1, r2, theta1, theta2, theta3)
  # y[[nlinks]] of observations
  # links contains the known LCS information of each link

  nlinks = length(links)
  r1 = x[1]
  r2 = x[2]
  x111 = links[[1]]$x[1,1]
  x112 = links[[1]]$x[2,1]
  x121 = links[[1]]$x[1,2]
  x122 = links[[1]]$x[2,2]
  x131 = links[[1]]$x[1,3]
  x132 = links[[1]]$x[2,3]
  x141 = links[[1]]$x[1,4]
  x142 = links[[1]]$x[2,4]

  y111 = y[[1]][1,1]
  y112 = y[[1]][2,1]
  y121 = y[[1]][1,2]
  y122 = y[[1]][2,2]
  y131 = y[[1]][1,3]
  y132 = y[[1]][2,3]
  y141 = y[[1]][1,4]
  y142 = y[[1]][2,4]

  if(nlinks ==1){
    theta1 = x[3]
    gradient = rep(NA, 3)
    for(i in 1:length(x)){
        gradtxtfile = sprintf("./AnalyticalCostGrad/SingleLink/CostGradientChar%.0f.txt", i)
        gradtxt = read.table(file = gradtxtfile, sep=',' , stringsAsFactors = FALSE)
        if((dim(gradtxt)[1] != 1) & (dim(gradtxt)[2] !=1)){stop("Error in reading gradient text file!")}
        gradient[i] = eval(parse(text = gradtxt[1,1]))
      }
    }else if(nlinks ==2){
    theta1 = x[3]
    theta2 = x[4]

    L1 = links[[1]]$length

    x211 = links[[2]]$x[1,1]
    x212 = links[[2]]$x[2,1]
    x221 = links[[2]]$x[1,2]
    x222 = links[[2]]$x[2,2]
    x231 = links[[2]]$x[1,3]
    x232 = links[[2]]$x[2,3]
    x241 = links[[2]]$x[1,4]
    x242 = links[[2]]$x[2,4]

    y211 = y[[2]][1,1]
    y212 = y[[2]][2,1]
    y221 = y[[2]][1,2]
    y222 = y[[2]][2,2]
    y231 = y[[2]][1,3]
    y232 = y[[2]][2,3]
    y241 = y[[2]][1,4]
    y242 = y[[2]][2,4]

    gradient = rep(NA, 4)
    for(i in 1:length(x)){
      gradtxtfile = sprintf("./AnalyticalCostGrad/DoubleLink/CostGradientChar%.0f.txt", i)
      gradtxt = read.table(file = gradtxtfile, sep=',' , stringsAsFactors = FALSE)
      if((dim(gradtxt)[1] != 1) & (dim(gradtxt)[2] !=1)){stop("Error in reading gradient text file!")}
      gradient[i] = eval(parse(text = gradtxt[1,1]))
    }

  }else if(nlinks ==3){
    theta1 = x[3]
    theta2 = x[4]
    theta3 = x[5]

    L1 = links[[1]]$length
    L2 = links[[2]]$length

    x211 = links[[2]]$x[1,1]
    x212 = links[[2]]$x[2,1]
    x221 = links[[2]]$x[1,2]
    x222 = links[[2]]$x[2,2]
    x231 = links[[2]]$x[1,3]
    x232 = links[[2]]$x[2,3]
    x241 = links[[2]]$x[1,4]
    x242 = links[[2]]$x[2,4]

    y211 = y[[2]][1,1]
    y212 = y[[2]][2,1]
    y221 = y[[2]][1,2]
    y222 = y[[2]][2,2]
    y231 = y[[2]][1,3]
    y232 = y[[2]][2,3]
    y241 = y[[2]][1,4]
    y242 = y[[2]][2,4]

    x311 = links[[3]]$x[1,1]
    x312 = links[[3]]$x[2,1]
    x321 = links[[3]]$x[1,2]
    x322 = links[[3]]$x[2,2]
    x331 = links[[3]]$x[1,3]
    x332 = links[[3]]$x[2,3]
    x341 = links[[3]]$x[1,4]
    x342 = links[[3]]$x[2,4]

    y311 = y[[3]][1,1]
    y312 = y[[3]][2,1]
    y321 = y[[3]][1,2]
    y322 = y[[3]][2,2]
    y331 = y[[3]][1,3]
    y332 = y[[3]][2,3]
    y341 = y[[3]][1,4]
    y342 = y[[3]][2,4]
    gradient = rep(NA, 5)
    for(i in 1:length(x)){
      gradtxtfile = sprintf("./AnalyticalCostGrad/TripleLink/CostGradientChar%.0f.txt", i)
      gradtxt = read.table(file = gradtxtfile, sep=',' , stringsAsFactors = FALSE)
      if((dim(gradtxt)[1] != 1) & (dim(gradtxt)[2] !=1)){stop("Error in reading gradient text file!")}
      gradient[i] = eval(parse(text = gradtxt[1,1]))
    }
  }
  return(gradient)
}

hess_analytical = function(x, y, links){
  # Generates the analytical hessian of the cost function.  Originally generated
  # via MATLAB and the symbolic toolbox.
  # x is parameter vector (r1, r2, theta1, theta2, theta3)
  # y[[nlinks]] of observations
  # links contains the known LCS information of each link

  nlinks = length(links)
  r1 = x[1]
  r2 = x[2]
  lsigma = x[length(x)]

  x111 = links[[1]]$x[1,1]
  x112 = links[[1]]$x[2,1]
  x121 = links[[1]]$x[1,2]
  x122 = links[[1]]$x[2,2]
  x131 = links[[1]]$x[1,3]
  x132 = links[[1]]$x[2,3]
  x141 = links[[1]]$x[1,4]
  x142 = links[[1]]$x[2,4]

  y111 = y[[1]][1,1]
  y112 = y[[1]][2,1]
  y121 = y[[1]][1,2]
  y122 = y[[1]][2,2]
  y131 = y[[1]][1,3]
  y132 = y[[1]][2,3]
  y141 = y[[1]][1,4]
  y142 = y[[1]][2,4]

  if(nlinks ==1){
    theta1 = x[3]
    hess = matrix(NA, nrow = length(x), ncol = length(x))
    for(i in 1:length(x)){
      for(j in 1:length(x)){
        hesstxtfile = sprintf("./AnalyticalHessian/SingleLink/hesschar%.0f_%.0f.txt", i,j)
        hesstxt = read.table(file = hesstxtfile, sep=',' , stringsAsFactors = FALSE)
        if((dim(hesstxt)[1] != 1) & (dim(hesstxt)[2] !=1)){stop("Error in reading hessian text file!")}
        hess[i,j] = eval(parse(text = hesstxt[1,1]))
      }
    }

  }else if(nlinks ==2){
    theta1 = x[3]
    theta2 = x[4]
    L1 = links[[1]]$length

    x211 = links[[2]]$x[1,1]
    x212 = links[[2]]$x[2,1]
    x221 = links[[2]]$x[1,2]
    x222 = links[[2]]$x[2,2]
    x231 = links[[2]]$x[1,3]
    x232 = links[[2]]$x[2,3]
    x241 = links[[2]]$x[1,4]
    x242 = links[[2]]$x[2,4]

    y211 = y[[2]][1,1]
    y212 = y[[2]][2,1]
    y221 = y[[2]][1,2]
    y222 = y[[2]][2,2]
    y231 = y[[2]][1,3]
    y232 = y[[2]][2,3]
    y241 = y[[2]][1,4]
    y242 = y[[2]][2,4]

    hess = matrix(NA, nrow = length(x), ncol = length(x))
    for(i in 1:length(x)){
      for(j in 1:length(x)){
        hesstxtfile = sprintf("./AnalyticalHessian/DoubleLink/hesschar%.0f_%.0f.txt", i,j)
        hesstxt = read.table(file = hesstxtfile, sep=',' , stringsAsFactors = FALSE)
        if((dim(hesstxt)[1] != 1) & (dim(hesstxt)[2] !=1)){stop("Error in reading hessian text file!")}
        hess[i,j] = eval(parse(text = hesstxt[1,1]))
      }
    }
  }else if(nlinks ==3){
    theta1 = x[3]
    theta2 = x[4]
    theta3 = x[5]

    L1 = links[[1]]$length
    L2 = links[[2]]$length

    x211 = links[[2]]$x[1,1]
    x212 = links[[2]]$x[2,1]
    x221 = links[[2]]$x[1,2]
    x222 = links[[2]]$x[2,2]
    x231 = links[[2]]$x[1,3]
    x232 = links[[2]]$x[2,3]
    x241 = links[[2]]$x[1,4]
    x242 = links[[2]]$x[2,4]

    y211 = y[[2]][1,1]
    y212 = y[[2]][2,1]
    y221 = y[[2]][1,2]
    y222 = y[[2]][2,2]
    y231 = y[[2]][1,3]
    y232 = y[[2]][2,3]
    y241 = y[[2]][1,4]
    y242 = y[[2]][2,4]

    x311 = links[[3]]$x[1,1]
    x312 = links[[3]]$x[2,1]
    x321 = links[[3]]$x[1,2]
    x322 = links[[3]]$x[2,2]
    x331 = links[[3]]$x[1,3]
    x332 = links[[3]]$x[2,3]
    x341 = links[[3]]$x[1,4]
    x342 = links[[3]]$x[2,4]

    y311 = y[[3]][1,1]
    y312 = y[[3]][2,1]
    y321 = y[[3]][1,2]
    y322 = y[[3]][2,2]
    y331 = y[[3]][1,3]
    y332 = y[[3]][2,3]
    y341 = y[[3]][1,4]
    y342 = y[[3]][2,4]

    hess = matrix(NA, nrow = length(x), ncol = length(x))
    for(i in 1:length(x)){
      for(j in 1:length(x)){
        hesstxtfile = sprintf("./AnalyticalHessian/TripleLink/hesschar%.0f_%.0f.txt", i,j)
        hesstxt = read.table(file = hesstxtfile, sep=',' , stringsAsFactors = FALSE)
        if((dim(hesstxt)[1] != 1) & (dim(hesstxt)[2] !=1)){stop("Error in reading hessian text file!")}
        hess[i,j] = eval(parse(text = hesstxt[1,1]))
      }
    }
  }
  return(hess)
}

LS_soln = function(y, links,
                   init_type = 'random',
                   inits = NA){
  # Computes the least squares solution given observations y.
  # y = observaitons
  # links = known LCS geometry
  # init_type = type of initial values to specify (random = randomly generated
  #             true_vals = true values of the simulation or speicified = custom
  #             specification of initial values.)
  # inits = specified initis if true_vals or specified is used for init_type
  nlinks = length(links)

  if(init_type =='random'){
    inits.r = c(runif(1, -0.1, 0.1),
                runif(1, -0.1, 0.1))
    inits.theta = runif(nlinks, -180, 180)
    print(paste('Computing LS solution with initial Values set to the RANDOM VALUES:', paste(c(inits.r, inits.theta), collapse = ', ' )))
  }else if(init_type == 'true_vals'){
    if (is.na(inits)){stop("If init_type is not random then inits must be specified")}
    print('Computing LS solution with initial Values set to the TRUE VALUES')
    inits.r = inits[1:2]
    inits.theta = inits[3:(nlinks +2)]
  }else if (init_type == "specified"){
    if (is.na(inits)){stop("If init_type is not random then inits must be specified")}
    print('Computing LS solution with initial Values set to the SPECIFIED VALUES')
    inits.r = inits[1:2]
    inits.theta = inits[3:(nlinks +2)]
  }
  inits = c(inits.r, inits.theta)

  # run optimisation using BFGS method.
  t1 = Sys.time()
  temp = optim(par=inits,fn = cost, gr = costgrad_analytical,
               y = y, links = links,
               method = "BFGS", control = list(trace=FALSE, maxit = 10000, reltol = 1e-20))
  t2 = Sys.time()
  return_list = list(r.hat = temp$par[1:2],
                     theta.hat = temp$par[3:(nlinks+2)],
                     value = temp$val, time = as.numeric(t2-t1))

  # generate residuals and use for corresponding estimate of sigma_hat
  nmarkers = 0
  obs.hat = gen_posture(links, return_list$r.hat, return_list$theta.hat)
  residual_sum = 0
  for(i in 1:nlinks){
    nmarkers = ncol(y[[i]])
    for(j in 1:nmarkers){
      residual_sum = residual_sum +
        (y[[i]][1, j]- obs.hat$alpha[[i]][1,j])^2 + # xresidual
        (y[[i]][2, j]- obs.hat$alpha[[i]][2, j])^2 # yresidual
      nmarkers = nmarkers +1
    }

  }
  p = length(return_list$r.hat) + length(return_list$theta.hat)
  return_list$sigma.hat = sqrt(residual_sum / (2*nmarkers))

  # Generate CI estimate via hessian matrix
  hess = hess_analytical(x = c(return_list$r.hat, return_list$theta.hat, log(return_list$sigma.hat)),
                         links = links,
                         y = y)
  fisher_info = solve(-hess)
  prop_sigma = diag(diag(sqrt(diag(fisher_info))))
  intervals = matrix(NA, nrow=nlinks+3, ncol =2)
  intervals[,1] = c(return_list$r.hat, return_list$theta.hat, return_list$sigma.hat) - 1.96*prop_sigma
  intervals[,2] = c(return_list$r.hat, return_list$theta.hat, return_list$sigma.hat) + 1.96*prop_sigma
  intervals[nrow(intervals), ] = exp(intervals[nrow(intervals),])
  return_list$intervals = intervals

  return(return_list)
}

########################### Section D  #########################
## Compute Bayesian solution.
################################################################

Bayes_soln = function(y, links, mdlfile,
                      true_vals,
                      init_type = 'random',
                      ls_est = NA,
                      ...){
  # Applies the Bayesian model to observations y and known data links.
  # y = observaitons
  # links = known LCS geometry
  # mdlfile = specified jags model file
  # true_vals = true values of the specified simulation.
  # init_type = type of initial values to specify (random = randomly generated
  #             true_vals = true values of the simulation or speicified = custom
  #             specification of initial values.)
  # inits = specified initis if true_vals is specified.

    nlinks = length(links)
    nmarkers = sapply(links, function(x){ncol(x$x)})
    M = 2 # dimension
    seg_lengths = sapply(links, function(x){x$length})
    x = lapply(links, function(x){x$x})

    # initilise x and y data for jags models
    xjags = yjags = array(NA, dim = c(nlinks, max(nmarkers), 2))
    for(i in 1:nlinks){
      xjags[i,,] = t(x[[i]])
      yjags[i,,] = t(y[[i]])
    }

    # input data for jags model
    jags_input = list(nlinks = nlinks,
                      nmarkers = nmarkers,
                      ndim = 2,
                      x = xjags,
                      y = yjags,
                      leng = cbind(seg_lengths, rep(0,nlinks)))

    # Specify initial values
    if(grepl('p4|p5', mdlfile)){
        # LS centered priors require the ls solution
      jags_input$ls_r = ls_est[1:2]
      jags_input$ls_theta = ls_est[3:(2+nlinks)]
      jags_input$ls_sigma = ls_est[length(ls_est)]
    }

    if(init_type =='true_vals'){
      r_true = true_vals[1:2]
      theta_true = true_vals[3:(2+nlinks)]
      sigma_true = true_vals[length(ls_est)]
      if(grepl('p3', mdlfile)){
        # if weakly informative prior specify inits in terms of hip, knee and ankle angles.
        print('Computing Bayes P3 solution with initial Values set to the TRUE VALUES')
        inits = list(hip = theta_true[1],
                     knee = theta_true[2] - theta_true[1],
                     ankle = -90 -theta_true[2] + theta_true[3],
                     r = r_true,
                     sigma_mm = sigma_true*1000)
      }else if(grepl('p2', mdlfile)){
        print('Computing Bayes P2 solution with initial Values set to the TRUE VALUES')
        inits = list(thetar = theta_true * pi/180,
                     r = r_true,
                     tau = 1/sigma_true/sigma_true)
        jags_input$true_vals = true_vals
      }else{
        print('Computing Bayes solution with initial Values set to the TRUE VALUES')
        inits = list(thetar = theta_true * pi/180,
                     r = r_true,
                     sigma = sigma_true)

      }
    }
    else if(init_type == 'random'){
      if(grepl('p3', mdlfile)){
          # if weakly informative prior specify inits in terms of hip, knee and ankle angles.
        print('Computing Bayes P3 solution with initial Values set to the RANDOM VALUES')
        r_random = rt_ls(2, df = 5, mu = 0, a = 1)
        hip_random = rt_ls(1, df = 5, mu=-45, a = 15)
        knee_random = rt_ls(1, df=5, mu=30, a=6)
        ankle_random = rt_ls(1, df=5, mu=0, a=7)
        sigma_mm_random = rgamma(1, shape = 1.2, scale=0.1)
        inits = list(hip = hip_random,
                     knee = knee_random,
                     ankle = ankle_random,
                     r = r_random,
                     sigma_mm = sigma_mm_random)
      }else if(grepl('p2', mdlfile)){
        print('Computing Bayes P2 solution with initial Values set to the RANDOM VALUES')
        r_random = c(rnorm(1, true_vals[1], 0.001), dnorm(1, true_vals[2], 0.001))
        theta_random = runif(nlinks, -180,180)
        tau_random = rnorm(1, 1/(true_vals[nlinks+3]*true_vals[nlinks+3]), 1)
        inits = list(thetar = theta_random * pi/180,
                     r = r_random,
                     tau = tau_random)
        jags_input$true_vals = true_vals
      }else if (grepl('p4', mdlfile)){
        print('Computing Bayes P4 solution with initial Values set to the RANDOM VALUES')
        r_random = c(runif(1, jags_input$ls_r[1]-0.1,jags_input$ls_r[1] + 0.1), runif(1, jags_input$ls_r[2]-0.1, jags_input$ls_r[2] + 0.1))
        theta_random = rep(0, nlinks)
        for(nl in 1:nlinks){
            theta_random[nl] = runif(1, jags_input$ls_theta[nl]-180, jags_input$ls_theta[nl]+180)
        }
        inits = list(theta = theta_random,
                     r = r_random,
                     sigma = runif(1, 0.1*jags_input$ls_sigma, 10*jags_input$ls_sigma))
      }else if (grepl('p5', mdlfile)){
        print('Computing Bayes P5 solution with initial Values set to the RANDOM VALUES')
        r_random = c(rnorm(1, jags_input$ls_r[1], 0.005), rnorm(1, jags_input$ls_r[2], 0.005))
        theta_random = rep(0, nlinks)
        for(nl in 1:nlinks){
          theta_random[nl] = rnorm(1, jags_input$ls_theta[nl], 1)
        }
        inits = list(theta = theta_random,
                     r = r_random,
                     sigma = abs(rnorm(1, jags_input$ls_sigma, 0.002)))
      }else{
        print('Computing Bayes P1 solution with initial Values set to the RANDOM VALUES')
        theta_random = runif(nlinks, -180,180)
        r_random = runif(2, -0.1, 0.1)
        inits = list(thetar = theta_random * pi/180,
                     r = r_random,
                     sigma = runif(1, 0.1*true_vals[nlinks+3], 10*true_vals[nlinks+3]))
      }
    }else if(init_type == 'ls_est'){
      if(sum(is.na(ls_est))>0){stop("If using 'ls_est' as initials please supply LS estimates")}
      if(grepl('p3', mdlfile)){
          # if wealky informative prior specify inits in terms of hip, knee and ankle angles.
        print('Computing Bayes P3 solution with initial Values set to the LS VALUES')
        hip_random = rt_ls(1, df = 5, mu=-45, a = 15)
        knee_random = rt_ls(1, df=5, mu=30, a=6)
        ankle_random = rt_ls(1, df=5, mu=0, a=7)

        inits = list(hip = hip_random,
                     knee = knee_random,
                     ankle = ankle_random,
                     r = c(ls_est[1], ls_est[2]),
                     sigma_mm = tail(ls_est,1)*1000)
      }else if(grepl('p2', mdlfile)){
        print('Computing Bayes P2 solution with initial Values set to the LS VALUES')
        jags_input$true_vals = true_vals
        inits = list(thetar = c(ls_est[3:(nlinks+2)]) * pi/180,
                     r = c(ls_est[1], ls_est[2]),
                     tau = 1/tail(ls_est,1)/tail(ls_est,1))
      }else if(grepl('p4|p5', mdlfile)){
          print('Computing Bayes P4 or P5 solution with initial Values set to the LS VALUES')
        inits = list(theta = c(ls_est[3:(nlinks+2)]),
                     r = c(ls_est[1], ls_est[2]),
                     sigma = tail(ls_est,1))
      }else if (grepl('p1_2', mdlfile)){
        print('Computing Bayes P1_2  solution with initial Values set to the LS VALUES')
        jags_input$true_vals = true_vals
        inits = list(thetar = c(ls_est[3:(nlinks+2)]) * pi/180,
                     r = c(ls_est[1], ls_est[2]),
                     tau = 1/tail(ls_est,1)/tail(ls_est,1))
      }
      else{
        print('Computing Bayes P1  solution with initial Values set to the LS VALUES')
        inits = list(thetar = c(ls_est[3:(nlinks+2)]) * pi/180,
                     r = c(ls_est[1], ls_est[2]),
                     sigma = tail(ls_est,1))
      }
    }

  # Compile jags model
  t1 = Sys.time()
  m1 = jags.model(file = mdlfile,
                  data = jags_input,
                  inits = inits,
                  n.chains = 4,
                  n.adapt = 10000
  )

  # Sample from model
  out1 = coda.samples(model = m1,
                      variable.names = c("theta", "r", "sigma"),
                      n.iter = 50000,
                      thin = 5)
  t2 = Sys.time()

  return(list(fit = out1, time = as.numeric(t2-t1)))
}


# EdgeR
x <- read.delim("file.txt", row.names = "Symbol")
group <- factor(c(1,1,2,2))
y <- DGEList(counts = x, group = group)
y <- calcNormFactors(y)
y <- estimateCommonDisp(y)
y <- estimateTagwiseDisp(y)
et <- exactTest(y)
topTags(et)
write.table(as.matrix(y$samples), file = "file_edgerR.txt")


library(jsonlite)
library(ggplot2)
library(zoo)
library(readr)

library(colorspace)
library(gridExtra)

library(plotly)
library(htmlwidgets)

library(sf)

library(lubridate)
library(plyr)

library(dplyr)

library(tidyr)
library(lubridate)

library(reshape2)

# get last_date_
load('data/latest/last_date_.Rda')

# get age data
json_data <- fromJSON('data/latest/last_data_po_osobama.json')

step <- 5
n <- 60

json_data <- json_data %>%  mutate(dob = ifelse(dob < 1901, NA, dob))

json_data$Datum <- as.Date(json_data$Datum, format="%Y-%m-%d")

json_data <- json_data[order(json_data$Datum),]

last_date <- strftime(json_data$Datum[nrow(json_data)], "%d.%m.%Y.")

json_data$dob <- as.Date(paste0(json_data$dob, '-01-01'), format="%Y-%m-%d")

json_data$age <- round(time_length(difftime(json_data$Datum, json_data$dob), "years"))

json_data$age_group <- findInterval(json_data$age, seq(0, 85, by=step))

labels <- paste0(seq(0, 85, by=step), '-', seq(step - 1, 85, by=step), sep='')

labels[length(labels)] = '85+'

json_data <- json_data %>% drop_na('Datum')

json_d2 <- json_data %>% group_by(Datum, age_group, spol, Zupanija) %>% tally()

age_reshaped2 <- pivot_wider(json_d2, names_from = age_group, values_from = n) %>%
  mutate_at(vars(-("Datum")), ~replace(., is.na(.), 0))

age_reshaped3 <- age_reshaped2[c('Datum', 'Zupanija', 'spol', as.character(1:length(labels)))]

colnames(age_reshaped3)[4:(3+length(labels))] <- labels

max_date = max(age_reshaped3$Datum) - days(2)
two_weeks_ago  = max_date - days(6)

counties <- unique(json_data[c("Zupanija")])

population_by_age_and_sex <- read.csv(file = 'data/cro_population_by_age_and_sex.csv')

f <- list(size = 13, color = "black")

i <- 0

p <- list()
a <- list()

for(county in c(sort(counties$Zupanija), 'Hrvatska')) {
  if (county == '') {
    next
  }

  i <- i + 1

  current_population <-c(population_by_age_and_sex[1:nrow(population_by_age_and_sex) - 1, c(i + 1)])

  current_population_M <-c(population_by_age_and_sex[1:nrow(population_by_age_and_sex) - 1, c((i + 1)) + 22])
  current_population_Z <-c(population_by_age_and_sex[1:nrow(population_by_age_and_sex) - 1, c((i + 1)) + 44])

  if (county == 'Hrvatska') {
    print(subset(age_reshaped3, (spol=='M') & (Datum >= two_weeks_ago)))
    total_nums_M <- as.data.frame(t(colSums(subset(age_reshaped3, (spol=='M') & (Datum >= two_weeks_ago))[, -c(1, 2, 3)])))
    total_nums_F <- as.data.frame(t(colSums(subset(age_reshaped3, (spol=='Ž') & (Datum >= two_weeks_ago))[, -c(1, 2, 3)])))
  }
  else {
    total_nums_M <- as.data.frame(t(colSums(subset(age_reshaped3, (spol=='M') & (Zupanija == county) & (Datum >= two_weeks_ago))[, -c(1, 2, 3)])))
    total_nums_F <- as.data.frame(t(colSums(subset(age_reshaped3, (spol=='Ž') & (Zupanija == county) & (Datum >= two_weeks_ago))[, -c(1, 2, 3)])))
  }

  total_nums <- sum(total_nums_M + total_nums_F)

  total_nums_M <- total_nums_M * -1

  m_melt <- melt(total_nums_M, value.name='Broj_slučajeva', variable.name = 'Dobna_skupina')
  f_melt <- melt(total_nums_F, value.name='Broj_slučajeva', variable.name = 'Dobna_skupina')

  m_melt$Spol <- 'M'
  f_melt$Spol <- 'Ž'

  m_melt$Populacija <- current_population_M
  f_melt$Populacija <- current_population_Z

  total_population <- sum(current_population_M + current_population_Z)

  m_melt$Incidencija_7d_na_100k <- (m_melt$Broj_slučajeva / m_melt$Populacija) * 100000
  f_melt$Incidencija_7d_na_100k <- (f_melt$Broj_slučajeva / f_melt$Populacija) * 100000

  total_7d_na_100k <- (total_nums / total_population) * 100000

  max_inc <- max(c(max(abs(m_melt$Incidencija_7d_na_100k)), max(f_melt$Incidencija_7d_na_100k)))

  max_inc <- max(c(300, (max_inc %/% 50 + 1) * 50))

  data <- rbind(m_melt, f_melt)

  data$pos <- ifelse(data$Broj_slučajeva < 0, 0, -20)

  g1 <- ggplot(data, aes(x = Dobna_skupina, y = Incidencija_7d_na_100k, fill= Spol,
                         text=paste('Broj slučajeva:', abs(Broj_slučajeva), '\nPopulacija:', Populacija))) +
    geom_bar(stat = "identity")+
    coord_flip(ylim = c(-max_inc, max_inc)) +
    scale_fill_brewer(palette = 'Set2', direction = -1)  +
    labs(x = 'Dobna skupina') +
    theme_minimal() +
    theme(legend.position = "none") +
    scale_y_continuous(labels = abs)

  g1

  p[[i]] <- ggplotly(g1)

  a[[i]] <- list(
    text = paste(county, round(total_7d_na_100k, digits=2), '/100k'),
    font = f,
    xref = "paper",
    yref = "paper",
    yanchor = "bottom",
    xanchor = "center",
    align = "center",
    x = 0.5,
    y = 1,
    showarrow = FALSE
  )

  p[[i]] <- p[[i]] %>%
    layout(annotations = a[i])

}

last_date <- paste(day(max_date), month(max_date), year(max_date), sep='.')
from_date <- paste(day(two_weeks_ago), month(two_weeks_ago), year(two_weeks_ago), sep='.')

s <- subplot(p, nrows = 5, margin=c(0.02), titleY = TRUE)%>%
  add_annotations(x = 0.7,
                  y = 0.07,
                  text = paste('COVID 19 u Hrvatskoj: Pregled broja zaraženih po dobnim skupinama i spolu (', from_date, ' - ', last_date ,')\n\nBroj zaraženih u zadnjih dostupnih 7 dana, normalizirano na 100000 stanovnika u svakoj dobnoj skupini.\nMuškarci su prikazani narančastom bojom na lijevoj strani, žene zelenom bojom na desnoj.\n\nGenerirano: ', format(Sys.time() + as.difftime(1, units="hours"), '%d.%m.%Y. %H:%M:%S h'), '\nIzvor podataka: koronavirus.hr (broj slučajeva), dzs.hr (broj stanovnika po dobnim skupinama i spolu, podaci iz 2019.)\n\nAutor: Petar Palašek', sep=''),
                  font = f,
                  xref = "paper",
                  yref = "paper",
                  align='left',
                  ax = 0,
                  ay = 0)

s

orca(s, file = paste('img/', last_date_, '_pyramid.png', sep = ''), width = 27 * 72, height = 13 * 72)

saveWidget(s, file = "html/index_pyramid.html", title = paste("COVID 19 u Hrvatskoj: Pregled broja zaraženih po dobnim skupinama i spolu (", last_date, ")", sep=""))


#' steadman_outdoor_sun
#'
#' Computes Steadman's apparent temperature under sunny outdoor conditions.
#'
#' @param t numeric       Air temperature in degC.
#' @param rh numeric      Relative humidity in percentage.
#' @param wind numeric    Wind speed in meters per second.
#' @param rshort numeric  Global short radiation in Watt/mq.
#' @param sunelev numeric Sun elevation in degrees.
#' @return steadman outdoor index
#'
#'
#' @author Istituto per la Bioeconomia CNR Firenze Italy  Alfonso Crisci \email{alfonso.crisci@@ibe.cnr.it}
#' @keywords  steadman, Apparent temperature, Sunny
#'
#' @export
#'
#'
#'
#'

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


# data_in is a comma separted list of data points
# groups_in is a comma separted list of group indeces for the points in data_in

MGRAST_do_stats <<- function (data_file,
                              groups_file,
                              data_type = c("raw", "normalized"),
                              sig_test = c(
                                "t-test-paired", "Wilcoxon-paired",
                                "t-test-un-paired", "Mann-Whitney_un-paired-Wilcoxon",
                                "ANOVA-one-way", "Kruskal-Wallis"
                                ),
                              file_out = "my_stats")

{

  ### SUB TO WRITE OUTPUT
  write_log <<- function (sig_test, data_type){
    write(paste("test is     : ", sig_test),    file = "do_stats.log")
    write(paste("data-type   : ", data_type),   file = "do_stats.log", append = TRUE)
    write(paste("num-samples : ", num_samples), file = "do_stats.log", append = TRUE)
    write(paste("num-groups  : ", num_groups),  file = "do_stats.log", append = TRUE)
  }

  ### SUB TO PREP DATA FOR TWO GROUP ANALYSES
  prep_two_groups <<- function(row_data){
    group_1 = levels(row_data[,2])[1]
    group_2 = levels(row_data[,2])[2]
    group_1_size = 0
    group_2_size = 0
    for (i in 1:as.matrix(dim(row_data)[1])){
      if(identical(as.character(row_data[i,2]), as.character(group_1))){
        group_1_size = group_1_size + 1
      }
      if(identical(as.character(row_data[i,2]), as.character(group_2))){
        group_2_size = group_2_size + 1
      }
    }
    group_1_data <<- matrix(,group_1_size,1)
    group_2_data <<- matrix(,group_2_size,1)
    group_1_index = 0
    group_2_index = 0
    for (i in 1:as.matrix(dim(row_data)[1])){
      if (identical(as.character(row_data[i,2]), as.character(group_1))){
        group_1_index = group_1_index + 1
        group_1_data[group_1_index,1] <<- row_data[i,1]
      }
      if (identical(as.character(row_data[i,2]), as.character(group_2))){
        group_2_index = group_2_index + 1
        group_2_data[group_2_index,1] <<- row_data[i,1]
      }
    }
  }

  ### ### MAIN SCRIPT STARTS HERE ### ###

  ### TEST TO MAKE SURE ALL OF THE ARGUMENTS ARE SUPPLIED
  #if()

  # LOAD NECESSARY PACKAGES
  library(stats)
  library(nlme)

  ### IMPORT AND FORMAT THE DATA ###
  all_data = data.frame(read.table(data_file, row.names=1, header=TRUE, sep="\t", comment.char="", quote=""))
  groups = data.matrix(scan(file = groups_file, what = "character", sep = "\t", quiet=TRUE))
  num_samples = dim(all_data)[2]
  num_rows = dim(all_data)[1]
  num_groups <<- nlevels(as.factor(groups[,1]))    # <----- Rats
  group_names <<- matrix(levels(as.factor(groups[,1])))

  # CREATE OUTPUT TABLE AND GIVE IT APPROPRIATE HEADERS
  output_table <<- data.frame(matrix(0, num_rows, num_groups+2))
  row.names(output_table) <<- row.names(all_data)
  names(output_table) <<- c(paste("group_(", levels(as.factor(groups[,1])),")_stddev",sep =""),
                            paste(sig_test, "_stat",sep=""),
                            paste(sig_test, "_p_value",sep="")
                            )

  ### PERFORM THE ANALYSES
  for (my_row in 1:num_rows){

    numeric_row_data <<- as.numeric(all_data[my_row,])
    factor_row_groups <<- as.character(groups[,1]) # is ok here
    row_data <<- cbind(numeric_row_data, factor_row_groups)
    row_data <<- data.frame(row_data)
    row_data[,1] <<- numeric_row_data # some values get changed if you don;t reload them here
    row_data[,2] <<- as.factor(row_data[,2])
    names(row_data)<<-c("values","ind")

    for (group in 1:num_groups){

      group_ind <<- levels(row_data[,2])[group]

      ### CALCULATE THE STANDARD DEVIATION FOR EACH GROUP
      num_samples_in_group <<- 0
      for(sample in 1:num_samples){
        if(identical(((matrix(row_data[sample,2]))[1,1]), group_ind)){
          if (num_samples_in_group==0){
            group_sample_counts <<- row_data[sample,1]
            num_samples_in_group <<- num_samples_in_group + 1
          }else{
            group_sample_counts <<- c(group_sample_counts, row_data[sample,1])
            num_samples_in_group <<- num_samples_in_group + 1
          }
        }
      }
      output_table[my_row, group] <<- as.real(sd(group_sample_counts))
    }

    if(identical(sig_test, "t-test-un-paired")){   # <-- new
      prep_two_groups(row_data)
      ttest_unpaired_output = t.test(group_1_data, group_2_data)
      t_unpaired_stat_value = as.real(ttest_unpaired_output["statistic"])
      t_unpaired_p_value = as.real(ttest_unpaired_output["p.value"])
      output_table[my_row, num_groups+1] <<- t_unpaired_stat_value
      output_table[my_row, num_groups+2] <<- t_unpaired_p_value
    }

    else if(identical(sig_test, "t-test-paired")){   # <-- new
      prep_two_groups(row_data)
      ttest_paired_output = t.test(group_1_data, group_2_data, paired = TRUE)
      t_paired_stat_value = as.real(ttest_paired_output["statistic"])
      t_paired_p_value = as.real(ttest_paired_output["p.value"])

      output_table[my_row, num_groups+1] <<- t_paired_stat_value
      output_table[my_row, num_groups+2] <<- t_paired_p_value
    }

    else if (identical(sig_test, "ANOVA-one-way")){
      anova_output = anova(aov(values~ind, data=row_data))
      anova_F = anova_output["F value"]
      F_value = as.real(anova_F[1,1])
      anova_p = anova_output["Pr(>F)"]
      anova_p_value = as.real(anova_p[1,1])
      output_table[my_row, num_groups+1] <<- F_value
      output_table[my_row, num_groups+2] <<- anova_p_value
    }

    else if (identical(sig_test, "Mann-Whitney_un-paired-Wilcoxon")){
      prep_two_groups(row_data)
      MWhitney_output = wilcox.test(group_1_data, group_2_data, exact=TRUE) # x -> s in text
      MWhitney_stat_value = as.real(MWhitney_output["statistic"])
      MWhitney_p_value = as.real(MWhitney_output["p.value"])
      output_table[my_row, num_groups+1] <<- MWhitney_stat_value
      output_table[my_row, num_groups+2] <<- MWhitney_p_value
    }

    else if (identical(sig_test, "Wilcoxon-paired")){   # <-- new
      prep_two_groups(row_data)
      wilcox_output = wilcox.test(group_1_data, group_2_data, exact=TRUE, paired=TRUE) # x -> s in text
      wilcox_stat_value = as.real(wilcox_output["statistic"])
      wilcox_p_value = as.real(wilcox_output["p.value"])
      output_table[my_row, num_groups+1] <<- wilcox_stat_value
      output_table[my_row, num_groups+2] <<- wilcox_p_value
    }

    else if (identical(sig_test, "Kruskal-Wallis")){
      kruskal_output = kruskal.test(row_data[,1], row_data[,2])
      kruskal_K_value = as.real(kruskal_output["statistic"])
      kruskal_p_value = as.real(kruskal_output["p.value"])
      output_table[my_row, num_groups+1] <<- kruskal_K_value
      output_table[my_row, num_groups+2] <<- kruskal_p_value
    }

    else{
      stop("no significance test was chosen")
    }

    write.table(output_table, file = file_out, sep = "\t", col.names=NA, row.names = TRUE)

  }

}


library(tidyverse)
library(lubridate)

# quick datetime info about me
today()

now()

now(tzone='UTC')  # change/pick time zone with tzone

# extract specific values
year(now())

month(now())

day(now())

?month
month(now(), label=TRUE)  # tell me the month
m <- month(now(), label=TRUE, abbr=FALSE)  # tell me the full month (spell it out)

### how to get day of week?
# day(now(), label=TRUE)  # ERROR
?day

mday(now())

wday(now())
wday(now(), label=TRUE)
wday(now(), label=TRUE, abbr=FALSE)

# other 'day' options
qday(now())

yday(now())

### how to add weekday (e.g. Friday) to day-month-year?
t <- now()

# both these convert day back to number (not label like expected)
cat(wday(t, label=TRUE, abbr=FALSE), ' ', day(t), '-', month(t), '-', year(t))
writeLines(c(wday(t, label=TRUE, abbr=FALSE), ' ', day(t), '-', month(t), '-', year(t)))

# this one works though (with day of week as label)
paste0(wday(t, label=TRUE, abbr=FALSE), ' ', day(t), '-', month(t), '-', year(t))
?paste


a<-Read.length.weight.relation()

a<-subset(a,Species.n %in% c(10,11,15:27))

subset(a,select=-Species.n)
l<-data.frame(l=(7:100)*10)
a<-droplevels(merge(a,l))

a$w<-a$a* a$l**a$b

#subset(a,Species=='Sprat')

a1<-subset(a,l %in% c(100,200,300,500,1000))
round(tapply(a1$w,list(a1$Species,a1$l),sum),3)

xyplot(w~l,data=a, group=Species,auto.key =   list(space = "right", points = FALSE, lines = TRUE))
#cleanup()


# context("Formulae")

# test_that("Formulas create the right model", {

set.seed(0772)
x <- rdrop_annotations(raphylo(50), .5)

m_mu <- aphylo_formula(x ~ mu_d)
m_mu_psi0 <- aphylo_formula(x ~ mu_d + psi)
m_mu_psi1 <- aphylo_formula(x ~ psi)
m_mu_psi2 <- aphylo_formula(x ~ psi + mu_d)

expect_equal(deparse(m_mu_psi0)[-1], deparse(m_mu_psi1)[-1])
expect_equal(deparse(m_mu_psi0)[-1], deparse(m_mu_psi2)[-1])

set.seed(071)
x <- rdrop_annotations(raphylo(50), .5)

expect_error(aphylo_formula(y ~ psi), "be found")
y <- 1
expect_error(aphylo_formula(y ~ psi), "should be either")

expect_error(aphylo_formula(x ~ mu_d, c(mu_d0=1, mu_d1=1, psi1=0)), "overspecified")
expect_error(aphylo_formula(x ~ mu_d, c(mu_d0=1)), "missing")

expect_error(aphylo_formula(x~mu_d(9)), "Arguments passed to")
expect_error(aphylo_formula(x~mu_d + I(x)), "supported")

set.seed(121)

x <- raphylo(30)
p <- matrix(runif(7*2), nrow=2, dimnames = NULL)

ctrl <- list(nchains=2, nsteps=500, burnin=10, conv_checker = NULL)

expect_warning(
  ans <- aphylo_mcmc(x ~ psi+ mu_d + eta + Pi, params = p, control = ctrl),
  "matched by position"
)

expect_identical(class(ans), "aphylo_estimates")

# aphylo_formula(x ~ psi + mu_d + mu_s + eta)$fun


#' @title Regression analysis of prevalence
#' @param table_file (optional) file to save parameter table to
#' @return a list of two plots (effect size and posterior predicitons) and a
#' table of effect size estimates
#' @importFrom dplyr select left_join mutate filter group_by ungroup inner_join bind_rows recode_factor summarise arrange if_else
#' @importFrom tidyr pivot_longer pivot_wider separate
#' @importFrom stats as.formula median quantile
#' @importFrom brms brm negbinomial
#' @importFrom tidybayes spread_draws median_qi
#' @importFrom forcats fct_rev
#' @importFrom ggplot2 ggplot aes xlab ylab xlim geom_hline coord_flip theme_minimal geom_point geom_ribbon theme scale_color_brewer scale_y_log10
#' @importFrom ggdist geom_pointinterval
#' @importFrom rstantools posterior_predict
#' @importFrom tidyselect starts_with matches
#' @importFrom tibble as_tibble
#' @importFrom kableExtra kable save_kable
#' @importFrom tools file_ext
#' @export
regression <- function(table_file = NULL) {
  unemp <- covariates$unemp
  age <- covariates$age
  pop_dens <- covariates$pop_dens
  roma <- covariates$roma

  ## all covariates and outcome
  prev <- ms.tst %>%
    dplyr::select(county, region, pop, dplyr::starts_with("attendance_"),
                  dplyr::starts_with("positive_"), pilot) %>%
    dplyr::left_join(unemp, by = "county") %>%
    dplyr::left_join(age, by = "county") %>%
    dplyr::left_join(pop_dens, by = "county") %>%
    dplyr::mutate(xcounty = sub(" [IV]+$",  "", county)) %>%
    dplyr::left_join(roma %>% select(xcounty = county, proportion_roma),
              by = "xcounty") %>%
    simplify_names() %>%
    dplyr::left_join(Rt.county %>%
                     rename(simple_name = county), by = "simple_name") %>%
    dplyr::select(-xcounty, -simple_name) %>%
    dplyr::mutate(unemp_rate = unemployed / active) %>%
    dplyr::select(county, region, pop, tidyselect::matches("^attendance_[123]"),
                  tidyselect::matches("^positive_[123]"), mean_age,
                  pop_dens, unemp_rate, proportion_roma, R)

  ## extract pilot variables
  pilot <- prev %>%
    dplyr::filter(!is.na(attendance_1)) %>%
    dplyr::mutate(round_attendance_prec = attendance_1 / pop,
                  round_prev_prec = positive_1 / attendance_1,
                  round_R_prec = R) %>%
    dplyr::select(county, dplyr::starts_with("round_")) %>%
    tidyr::pivot_longer(-county) %>%
    dplyr::group_by(name) %>%
    dplyr::mutate(value = (value - mean(value)) / sd(value)) %>%
    dplyr::ungroup() %>%
    tidyr::pivot_wider() %>%
    dplyr::mutate(`0` = 0, `1` = 1, `2` = 1) %>%
    tidyr::pivot_longer(tidyselect::matches("^[012]"),
                        names_to = "round", values_to = "multiplier") %>%
    dplyr::mutate(round = as.integer(round)) %>%
    tidyr::pivot_longer(c(-county, -round, -multiplier)) %>%
    dplyr::mutate(value = value * multiplier) %>%
    tidyr::pivot_wider() %>%
    dplyr::select(-multiplier)

  ## extract round 1 variables
  round1 <- prev %>%
    dplyr::filter(is.na(attendance_1)) %>%
    dplyr::mutate(round_attendance_prec = attendance_2 / pop,
                  round_prev_prec = positive_2 / attendance_2,
                  round_R_prec = R) %>%
    dplyr::select(county, tidyselect::starts_with("round_")) %>%
    tidyr::pivot_longer(-county) %>%
    dplyr::group_by(name) %>%
    dplyr::mutate(value = (value - mean(value)) / sd(value)) %>%
    dplyr::ungroup() %>%
    pivot_wider() %>%
    dplyr::mutate(`0` = 0, `1` = 1) %>%
    tidyr::pivot_longer(tidyselect::matches("^[01]"),
                        names_to = "round", values_to = "multiplier") %>%
    dplyr::mutate(round = as.integer(round)) %>%
    tidyr::pivot_longer(c(-county, -round, -multiplier)) %>%
    dplyr::mutate(value = value * multiplier) %>%
    tidyr::pivot_wider() %>%
    dplyr::select(-multiplier)

  prev_long <- prev %>%
    tidyr::pivot_longer(tidyselect::matches("^(positive|attendance)_[123]$")) %>%
    tidyr::separate(name, c("name", "round"), sep = "_") %>%
    dplyr::select(-R) %>%
    dplyr::filter(!is.na(value)) %>%
    tidyr::pivot_wider() %>%
    tidyr::pivot_longer(c(-county, -region, -positive, -attendance, -round)) %>%
    dplyr::group_by(name) %>%
    dplyr::mutate(value = (value - mean(value, na.rm = TRUE)) /
                    sd(value, na.rm = TRUE)) %>%
    dplyr::ungroup() %>%
    tidyr::pivot_wider() %>%
    dplyr::group_by(county) %>%
    dplyr::mutate(round = as.integer(round),
                  round = dplyr::if_else(rep(any(round == 1), n()),
                                         round - 1L, round - 2L)) %>%
    dplyr::ungroup()

  pilot_long <- prev_long %>%
    dplyr::inner_join(pilot, by = c("county", "round"))
  round1_long <- prev_long %>%
    dplyr::inner_join(round1, by = c("county", "round"))

  prev_long <- pilot_long %>%
    dplyr::bind_rows(round1_long)

  model <-
    stats::as.formula(positive ~
                        1 + (1 | county) + round + mean_age + pop_dens +
                        unemp_rate + proportion_roma + round_attendance_prec +
                        round_prev_prec + round_R_prec +
                        offset(log(attendance)))

  ## Fit model --------------------------------------------------------------
  fit <- brms::brm(model, data = prev_long, family = brms::negbinomial(),
                   iter = 3000)

  effects <- fit %>%
    tidybayes::spread_draws(`^b_.*`, regex = TRUE) %>%
    tidybayes::median_qi(.width = c(.95, .50)) %>%
    tidyr::pivot_longer(dplyr::starts_with("b_")) %>%
    dplyr::mutate(name =
                    dplyr::if_else(grepl("\\.", name), name,
                                   paste(name, .point, sep = "."))) %>%
    tidyr::separate(name, c("variable", "name"), sep = "\\.") %>%
    tidyr::pivot_wider() %>%
    dplyr::mutate(affects = dplyr::if_else(variable %in% c("b_Intercept",
                                                           "b_mean_age",
                                                           "b_pop_dens",
                                                           "b_unemp_rate",
                                                           "b_proportion_roma"),
                                           "Prevalence", "Reduction"),
                  variable =
                    dplyr::recode_factor(
                             variable,
                             b_Intercept = "Intercept",
                             b_mean_age = "Mean age",
                             b_pop_dens =  "Population density",
                             b_unemp_rate = "Unemployment rate",
                             b_proportion_roma = "Size of Marginalised Roma Community",
                             b_round = "Round",
                             b_round_attendance_prec = "Previous attendance",
                             b_round_prev_prec = "Previous prevalence",
                             b_round_R_prec = "Reproduction number"
                           ),
                  variable = forcats::fct_rev(variable))

  ep <-
    ggplot2::ggplot(effects %>%
                    dplyr::filter(variable != "Intercept") %>%
                    dplyr::mutate_at(vars(median, lower, upper), exp),
                    ggplot2::aes(x = variable, y = median,
                                 ymin = lower, ymax = upper,
                                 colour = affects)) +
    ggdist::geom_pointinterval() +
    ggplot2::xlab("") + ggplot2::ylab("Posterior ratio") +
    ggplot2::geom_hline(yintercept = 1, linetype = "dashed") +
    ggplot2::ylim(c(0.25, 1.75)) +
    ggplot2::coord_flip() +
    ggplot2::theme_minimal() +
    ggplot2::scale_color_brewer("", palette = "Set1") +
    ggplot2::theme(legend.position = "none")

  ## Posterior predictive plot -----------------------------------------------
  yhat <- rstantools::posterior_predict(fit)
  colnames(yhat) <- paste(prev_long$county, prev_long$round, sep = "_")

  plotpp <- tibble::as_tibble(yhat) %>%
    tidyr::pivot_longer(everything(), names_to = "county_round") %>%
    tidyr::separate(county_round, c("county", "round"), sep = "_") %>%
    dplyr::mutate(round = as.integer(round)) %>%
    dplyr::group_by(county, round) %>%
    dplyr::summarise(median = stats::median(value),
                     lower = stats::quantile(value, 0.25),
                     upper = stats::quantile(value, 0.75),
                     lowest = stats::quantile(value, 0.05),
                     uppest = stats::quantile(value, 0.95),
                     .groups = "drop") %>%
    dplyr::ungroup() %>%
    dplyr::left_join(prev_long, by = c("county", "round")) %>%
    dplyr::arrange(median) %>%
    dplyr::mutate(id = seq_len(n())) %>%
    dplyr::group_by(county) %>%
    dplyr::mutate(round = dplyr::if_else(rep(any(round == 2), n()),
                                         round + 1, round + 2)) %>%
    dplyr::ungroup() %>%
    dplyr::mutate(round = dplyr::if_else(round == 1, "Pilot",
                                         paste("Round", round - 1)))

  pp <- ggplot2::ggplot(plotpp, aes(x = id, y = median, color = round)) +
    ggplot2::geom_point(aes(y = positive), size = 1) +
    ggplot2::geom_ribbon(aes(ymin = lower, ymax = upper), alpha = 0.3,
                         color = NA) +
    ggplot2::geom_ribbon(aes(ymin = lowest, ymax = uppest), alpha = 0.15,
                         color = NA) +
    ggplot2::xlab("County") +
    ggplot2::ylab("Estimated # positive") +
    ggplot2::theme_minimal() +
    ggplot2::theme(axis.text.x = element_blank(),
                   axis.ticks.x = element_blank()) +
    ggplot2::scale_color_brewer("", palette = "Dark2") +
    ggplot2::scale_y_log10()

  if (!is.null(table_file)) {
    align <- c("l|", "r", "r", "r")
    if (file_ext(table_file) == "pdf") {
      format <- "latex"
    } else if (file_ext(table_file) == "html") {
      format <- "html"
      align <- sub("\\|", "", align)
    }
    col.names <- c("Variable", "Lower 95%", "Median", "Upper 95%")
    k <- kableExtra::kable(effects %>%
                           dplyr::filter(.width == 0.95) %>%
                           dplyr::select(variable, lower, median, upper) %>%
                           dplyr::mutate_if(is.numeric, exp) %>%
                           dplyr::mutate_if(is.numeric, signif, digits = 2) %>%
                           dplyr::mutate_if(is.numeric, as.character),
                           format = format,
                           col.names = col.names,
                           align = align,
                           booktabs = FALSE)

    kableExtra::save_kable(k, table_file)
  }

  return(list(plots = list(effects = ep,
                           predictions = pp),
              table = effects,
              covariates = prev))
}