# load sparse matrix package
suppressPackageStartupMessages(library("Matrix"))

# access a numeric column
get_numeric <- function(table, column_key) {
    column <- as.numeric(column_key)
    column_data <- suppressWarnings(as.numeric(as.character(table[column][[1]])))
    return(c(column_data))
}

# access a label column
get_label <- function(table, column_key) {
    column <- as.numeric(column_key)
    column_data <- as.character(table[column][[1]])
    return(c(column_data))
}

# inflate three columns into matrix
matrify <- function(data) {
    if (ncol(data) != 3)
        stop("Data frame must have three column format")
    plt <- data[, 1]
    spc <- data[, 2]
    abu <- data[, 3]
    plt_codes <- levels(factor(plt))
    spc_codes <- levels(factor(spc))
    taxa <- Matrix(0, nrow = length(plt_codes), ncol = length(spc_codes), sparse = TRUE)
    row <- match(plt, plt_codes)
    col <- match(spc, spc_codes)
    for (i in seq_len(length(abu))) {
        taxa[row[i], col[i]] <- abu[i]
    }
    colnames(taxa) <- spc_codes
    rownames(taxa) <- plt_codes
    taxa
}

# flatten data.frame into three column format
flatten <- function(my_matrix) {
    summ <- summary(my_matrix)
    summ <- data.frame(i = rownames(my_matrix)[summ$i], j = colnames(my_matrix)[summ$j], x = summ$x)
    summ
}

# wrapper
wrapper <- function(table, columns, options) {

    # initialize output list
    l <- list()

    # get number of columns
    n <- length(columns)

    # consistency check
    if (n %% 3 != 0) {
        print("heatmap::wrapper() - Data not consistent (n mod 3 != 0)")
        return(l)
    }

    # create index sequence
    index <- seq(1, n, by = 3)

    # get keys
    keys <- names(columns)

    # loop through blocks
    for (i in index) {
        # create columns
        ci <- get_label(table, columns[keys[i]])
        cj <- get_label(table, columns[keys[i + 1]])
        cx <- get_numeric(table, columns[keys[i + 2]])

        # create a frame from columns
        my_frame <- data.frame(ci = ci, cj = cj, cx = cx)

        # create matrix out of the frame
        my_matrix <- matrify(my_frame)

        # create/cluster matrix
        row_order <- hclust(dist(my_matrix))$order
        col_order <- hclust(dist(t(my_matrix)))$order

        # reorder matrix
        my_matrix <- my_matrix[row_order, col_order]

        # transform back to three columns
        my_flatmatrix <- flatten(my_matrix)

        # append to result list
        l <- append(l, list(my_flatmatrix$i))
        l <- append(l, list(my_flatmatrix$j))
        l <- append(l, list(my_flatmatrix$x))
    }

    # return
    return(l)
}


#' Analyze cell cell cor
#'
#'
#'
#' @param mat_id matrix to use
#' @param gset_id features to use for computing cors
#' @param n_dsamp number of umis to for downsampling. If this is -1, no dsamp will be performed
#'
#' @export
#'

mcell_scmat_plot_cmp_kcor = function(mat_id, gset_id)
{
	feat = gset_get_feat_mat(gset_id, mat_id, downsamp=T)
	k_nonz_exp = get_param("scm_k_nonz_exp")
#force given dsamp?
	feat = log2(1+k_nonz_exp*as.matrix(feat))

	raw_cor = tgs_cor(feat)

#distribution of k'th top cor
	fn = scfigs_fn(mat_id, sprintf("k_cor_cmp_%s", gset_id))
	png(fn, w=1200, h=600)
	layout(matrix(c(1,5,2,6,3,7,4,8), ncol=4))
	k_titer = apply(raw_cor, 1, max)
	diag(raw_cor) = 0
	min_cor = min(raw_cor) - 0.03
	max_cor = max(raw_cor) + 0.03
	max_lk = min(floor(log2(ncol(feat))), 11)
	ref_cor = apply(raw_cor, 1, function(x) { -sort(-x, partial=4)[4] })
	for(k in 2**(4:max_lk)) {
		k_cor = apply(raw_cor, 1, function(x) { -sort(-x, partial=k)[k] })
		plot(ref_cor, k_cor, pch=19, cex=1,
					main=sprintf("comparing K=%d",k),
					xlim=c(min_cor, max_cor), ylim=c(min_cor, max_cor),
					xlab="knn k=4", ylab=sprintf("knn k= %d", k))
		grid()
		abline(b=1,a=0, lty=2)
	}
	dev.off()
	rank_out = apply(raw_cor, 1, rank)
	rank_in = t(rank_out)
	f = rank_out<200
	fn = scfigs_fn(mat_id, "cor_in_out")
	png(fn, w=800, h=800)
	cor_shades = colorRampPalette(c("darkblue", "blue", "black", "red", "yellow"))(201)
	smoothScatter(as.vector(rank_out)[f], log2(1+as.vector(rank_in)[f]),
				nrpoints = ncol(rank_out)*2, cex=0.4, pch=19,
				colramp = colorRampPalette(c("white", "blue", "orange")))
#				col = cor_shades[ceiling(100*(1+as.vector(raw_cor)[f]))])
	dev.off()
	return(list(rank_out, rank_in))
}


# 3. faza: Vizualizacija podatkov

library(ggplot2)
library(dplyr)
#========================================================================================================
#GRAFI
#st.porok <- ggplot(osnovni.podatki.poroke %>% filter(spremenljivka == "Sklenitve zakonskih zvez - Skupaj"),
#                   aes(x = leto, y = vrednost)) + geom_line() +
 # xlab("Leto") + ylab("Stevilo porok") +
#  theme(axis.text.x = element_text(angle = 90, vjust = 0.5, hjust = 1))

#st.razvez <- ggplot(osnovni.podatki.razveze %>% filter(spremenljivka == "Razveze - SKUPAJ"),
 #                   aes(x = leto, y = vrednost)) + geom_line() +
#  xlab("Leto") + ylab("Število razvez") +
 # theme(axis.text.x = element_text(angle = 90, vjust = 0.5, hjust = 1))

osnovni.podatki <- rbind(osnovni.podatki.poroke, osnovni.podatki.razveze)

st.porok1 <- ggplot(osnovni.podatki %>%
                      filter(spremenljivka %in% c("Sklenitve zakonskih zvez - Skupaj",
                                                  "Razveze - SKUPAJ")),
                    aes(x = leto, y = vrednost, color = spremenljivka)) + geom_line() +
  xlab("Leto") + ylab("Število") +
  theme(axis.text.x = element_text(angle = 90, vjust = 0.5, hjust = 1)) +
  scale_color_discrete(name = "Zakonske zveze",
                       breaks = c("Sklenitve zakonskih zvez - Skupaj",
                                  "Razveze - SKUPAJ"),
                       labels = c("Poroke", "Razveze"))

#========================================================================================================
#ZDRUŽITEV
#st.porok1 <- ggplot() + geom_line(data = osnovni.podatki.poroke %>% filter(spremenljivka == "Sklenitve zakonskih zvez - Skupaj"),
#                                                            aes(x = leto, y= vrednost), color="red") +
 # geom_line(data = osnovni.podatki.razveze %>% filter(spremenljivka == "Razveze - SKUPAJ"),
#            aes(x = leto, y = vrednost), color="blue") +
#  xlab("Leto") + ylab("Število") +
#    theme(axis.text.x = element_text(angle = 90, vjust = 0.5, hjust = 1))

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

#razveze.z.otroki <- ggplot(osnovni.podatki.razveze %>% filter(spremenljivka == "Razveze zakonskih zvez z otroki"),
#                           aes(x = leto, y = vrednost)) + geom_line() +
#  xlab("Leto") + ylab("Razveze zakonskih zvez z otroki") +
#  theme(axis.text.x = element_text(angle = 90, vjust = 0.5, hjust = 1))
#
#razveze.brez.otrok <- ggplot(osnovni.podatki.razveze %>% filter(spremenljivka == "Razveze zakonskih zvez brez otrok"),
#                           aes(x = leto, y = vrednost)) + geom_line() +
#  xlab("Leto") + ylab("Razveze zakonskih zvez brez otrok") +
#  theme(axis.text.x = element_text(angle = 90, vjust = 0.5, hjust = 1))
#========================================================================================================
#ZDRUŽITEV
#otroci <- ggplot() + geom_line(data = osnovni.podatki.razveze %>% filter(spremenljivka == "Razveze zakonskih zvez z otroki"),
#                               aes(x = leto, y = vrednost), color = "red") +
#  geom_line(data = osnovni.podatki.razveze %>% filter(spremenljivka == "Razveze zakonskih zvez brez otrok"),
#            aes(x = leto, y = vrednost), color = "orange") +
#  xlab("Leto") + ylab("Število") +
#  theme(axis.text.x = element_text(angle = 90, vjust = 0.5, hjust = 1))

otroki <- ggplot(osnovni.podatki %>%
                      filter(spremenljivka %in% c("Razveze zakonskih zvez z otroki",
                                                  "Razveze zakonskih zvez brez otrok")),
                    aes(x = leto, y = vrednost, color = spremenljivka)) + geom_line() +
  xlab("Leto") + ylab("Število") +
  theme(axis.text.x = element_text(angle = 90, vjust = 0.5, hjust = 1)) +
  scale_color_discrete(name = "Legenda",
                       breaks = c("Razveze zakonskih zvez z otroki",
                                  "Razveze zakonskih zvez brez otrok"),
                       labels = c("Razveze z otroki", "Razveze brez otrok"))

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

prve.zveze <-ggplot(osnovni.podatki.poroke %>% filter(spremenljivka == "Prve sklenitve zakonskih zvez"),
                                 aes(x = leto, y = vrednost)) + geom_line() +
  xlab("Leto") + ylab("Prve sklenitve zakonskih zvez") +
  theme(axis.text.x = element_text(angle = 90, vjust = 0.5, hjust = 1))

#========================================================================================================
# trajanje200 <- ggplot() + geom_line(data = osnovni.podatki.razveze %>% filter(spremenljivka == "Trajanje zakonske zveze 5-9 let"),
#                                  aes(x = leto, y = vrednost), color = "red") +
#   geom_line(data = osnovni.podatki.razveze %>% filter(spremenljivka == "Trajanje zakonske zveze pod 1 leto"),
#             aes(x = leto, y = vrednost), colour = "blue") +
#   geom_line(data = osnovni.podatki.razveze %>% filter(spremenljivka == "Trajanje zakonske zveze 1-4 leta"),
#             aes(x = leto, y = vrednost), colour = "green") +
#   geom_line(data = osnovni.podatki.razveze %>% filter(spremenljivka == "Trajanje zakonske zveze 10-14 let"),
#             aes(x = leto, y = vrednost), colour = "orange") +
#   geom_line(data = osnovni.podatki.razveze %>% filter(spremenljivka == "Trajanje zakonske zveze 15 let ali vec"),
#             aes(x = leto, y = vrednost), colour = "yellow") +
#   xlab("Leto") + ylab("Število") +
#   theme(axis.text.x = element_text(angle = 90, vjust = 0.5, hjust = 1))

trajanje <- ggplot(osnovni.podatki %>%
                   filter(spremenljivka %in% c("Trajanje zakonske zveze pod 1 leto",
                                               "Trajanje zakonske zveze 1-4 leta",
                                               "Trajanje zakonske zveze 5-9 let",
                                               "Trajanje zakonske zveze 10-14 let",
                                               "Trajanje zakonske zveze 15 let ali vec")),
                 aes(x = leto, y = vrednost, color = spremenljivka)) + geom_line() +
  xlab("Leto") + ylab("Število") +
  theme(axis.text.x = element_text(angle = 90, vjust = 0.5, hjust = 1)) +
  scale_color_discrete(name = "Trajanje zakonske zveze",
                       breaks = c("Trajanje zakonske zveze pod 1 leto",
                                  "Trajanje zakonske zveze 1-4 leta",
                                  "Trajanje zakonske zveze 5-9 let",
                                  "Trajanje zakonske zveze 10-14 let",
                                  "Trajanje zakonske zveze 15 let ali vec"),
                       labels = c("Pod 1 leto",
                                  "1-4 leta",
                                  "5-9 let",
                                  "10-14 let",
                                  "15 let ali več"))

#trajanje5 <- ggplot(osnovni.podatki.razveze %>% filter(spremenljivka == "Trajanje zakonske zveze 5-9 let"),
#                    aes(x = leto, y = vrednost)) + geom_line() +
#  xlab("Leto") + ylab("Trajanje zakonske zveze 5-9 let") +
#  theme(axis.text.x = element_text(angle = 90, vjust = 0.5, hjust = 1))

# trajanje0 <- ggplot(osnovni.podatki.razveze %>% filter(spremenljivka == "Trajanje zakonske zveze pod 1 leto"),
#                     aes(x = leto, y = vrednost)) + geom_line() +
#   xlab("Leto") + ylab("Trajanje zakonske zveze pod 1 leto") +
#   theme(axis.text.x = element_text(angle = 90, vjust = 0.5, hjust = 1))
#
#
# trajanje1 <- ggplot(osnovni.podatki.razveze %>% filter(spremenljivka == "Trajanje zakonske zveze 1-4 leta"),
#                     aes(x = leto, y = vrednost)) + geom_line() +
#   xlab("Leto") + ylab("Trajanje zakonske zveze 1-4 leta") +
#   theme(axis.text.x = element_text(angle = 90, vjust = 0.5, hjust = 1))
#
# trajanje10 <- ggplot(osnovni.podatki.razveze %>% filter(spremenljivka == "Trajanje zakonske zveze 10-14 let"),
#                     aes(x = leto, y = vrednost)) + geom_line() +
#   xlab("Leto") + ylab("Trajanje zakonske zveze 10-14 let") +
#   theme(axis.text.x = element_text(angle = 90, vjust = 0.5, hjust = 1))
#
# trajanje15 <- ggplot(osnovni.podatki.razveze %>% filter(spremenljivka == "Trajanje zakonske zveze 15 let ali vec"),
#                      aes(x = leto, y = vrednost)) + geom_line() +
#    xlab("Leto") + ylab("Trajanje zakonske zveze 15 let ali vec") +
#    theme(axis.text.x = element_text(angle = 90, vjust = 0.5, hjust = 1))

#========================================================================================================
#ZEMLJEVID
library(sp)
library(maptools)
library(digest)
gpclibPermit()

zemljevid <- uvozi.zemljevid("http://biogeo.ucdavis.edu/data/gadm2.8/shp/SVN_adm_shp.zip",
                             "SVN_adm1", encoding = "") %>% pretvori.zemljevid()

levels(zemljevid$NAME_1)[levels(zemljevid$NAME_1) %in%
                           c("Notranjsko-kraška",
                             "Spodnjeposavska", "Koroška", "Goriška", "Obalno-kraška")] <- c("Primorsko-notranjska",
                                                      "Posavska", "Koroska", "Goriska", "Obalno-kraska")
#========================================================================================================
#POROKE
poroke <- poroke.regije[, names(poroke.regije), drop = F]

povprecje <- poroke %>% group_by(regija) %>% summarise(poroke = mean(stevilo))

zemljevid.poroke <- ggplot() +
  geom_polygon(data = povprecje %>% right_join(zemljevid, by = c("regija" = "NAME_1")),
               aes(x = long, y = lat, group = group, fill = poroke))+
  xlab("") + ylab("") + ggtitle("Število porok po slovenskih regijah")

#zemljevid.poroke + scale_fill_gradient(low='green', high='red')

zemljevid.poroke + scale_fill_gradient(low = "#132B43", high = "#56B1F7", space = "Lab",
na.value = "grey50", guide = "colourbar")

#========================================================================================================
#RAZVEZE
razveze <- razveze.regije[, names(razveze.regije), drop = F]

povprecje <- razveze %>% group_by(regija) %>% summarise(razveze = mean(stevilo))

zemljevid.razveze <- ggplot() +
  geom_polygon(data = povprecje %>% right_join(zemljevid, by = c("regija" = "NAME_1")),
               aes(x = long, y = lat, group = group, fill = razveze))+
  xlab("") + ylab("") + ggtitle("Število razvez po slovenskih regijah")

zemljevid.razveze + scale_fill_gradient(low = "#ffb7a8", high = "#bc4229", space = "Lab",
                                       na.value = "grey50", guide = "colourbar")


designBasedContNullBatch = function(gamma_vec, outcome_mat, pcf_cat_vec, instid_vec){
	#Input an N x iterations matrix of null data

	##Computes D-G z scores less cost prohabitivly....
	#There is a lot of redundancy in the computation

	##TODO add tests to make sure weird ordering isnt hurting anything

	##TODO make sure to test that it will work with an input vector...

	###Draper Gittoes
	#M student types - pcf categories
	#N universities
	#n_ga,,a gamma types
	#iters, number of iterations
	#N_total - overall number of students

	#Extract variables
	pcf_cat_vec = as.factor(pcf_cat_vec)
	pcf_cat_vec_i = as.integer(pcf_cat_vec)
	instid_vec = as.factor(instid_vec)
	instid_vec_i = as.integer(instid_vec)

	M = length(levels(pcf_cat_vec))
	N = length(levels(instid_vec))
	n_gamma = length(gamma_vec)
	iters = dim(outcome_mat)[2]

	#Build N x M count matirx and fill in
	#Also count mean and SD
	n_mat = matrix(NA, nrow = N, ncol = M)
	mean_array = var_array = array(0, c(N,M, iters))
	#Arrays are N by M by iters
	for (i in 1:N){#Loop over institutions
		for (j in 1:M){#Loop over pcf categories
			indices = (pcf_cat_vec_i == j &
					instid_vec_i == i)
			n = sum(indices)
			n_mat[i, j] = n

			if (n > 0){
				outcome_mat_small = matrix(outcome_mat[indices, ], ncol = iters)
				mean_array[i, j, ] = apply(outcome_mat_small,
									2, mean)
				var_array[i, j, ] = apply(outcome_mat_small,
									2, var)
			}
		}
	}

	##Compute marginals (N or M by iters)
	n_u_vec = apply(n_mat, 1, sum)
	n_cat_vec = apply(n_mat, 2, sum)
	pcf_ybar_mat = matrix(NA, nrow = M, ncol = iters)
	for (i in 1:iters){
		pcf_ybar_mat[ ,i] = sapply(levels(pcf_cat_vec), function(x)
			mean(outcome_mat[pcf_cat_vec == x,i]))
	}

	#Compute 3d array of lambdas
	lambdaFun = function(i,k,j){
		if (i == k){
			(n_mat[i,j] / n_u_vec[i]) *
				(1 - (n_mat[i,j] / (n_cat_vec[j])))
		} else {
			-(n_mat[i,j] * n_mat[k,j])/(n_u_vec[i] * n_cat_vec[j])
		}
	}

	lambda_array =  array(NA, c(N, N, M) )
	for (i in 1:N){
		for (k in 1:N){
			for (j in 1:M){
				lambda_array[i, k, j] = lambdaFun(i,k,j)
			}
		}
	}
	lambda_array_squared = lambda_array^2

	z_array = se_array =  array(NA, c(N, n_gamma, iters))
	d_mat = o_mat = e_mat = matrix(NA, nrow = N, ncol = iters)
	n_array = outer(n_mat, rep(1, n_gamma)) #Extend n_mat into a 3rd dimention
	for (i in 1:iters){
		#Compute V(D_i) mat (N x )
		var_global = var(outcome_mat[ ,i])
		var_mat =  var_array[ , ,i]
		var_mat[n_mat == 1] = var_global
		var_array[ , ,i] = var_mat

		var_di_mat =  matrix(NA, nrow = N, ncol = n_gamma)
		di_vec = sapply(1:N, function(x)
			sum(lambda_array[x,,] * mean_array[ , ,i], na.rm = TRUE))
		o_vec = sapply(levels(instid_vec), function(x)
			mean(outcome_mat[instid_vec == x,i]))
		e_vec = sapply(1:N, function(x)
			sum(n_mat[x, ] * pcf_ybar_mat[ ,i])) /
			n_u_vec
		d_mat[ ,i] = di_vec; o_mat[ ,i] = o_vec; e_mat[ ,i] = e_vec

		#Compute SE and Z w/o using a loop over gamma
		var_gamma_array = ((outer(var_mat, rep(1, n_gamma)) *
				  outer(matrix(1,nrow = N, ncol = M), 1-gamma_vec )) + outer( matrix(var_global, nrow = N, ncol = M), gamma_vec) )
		 var_gamma_array[n_array > 0] = var_gamma_array[n_array > 0] / n_array[n_array > 0]
		# var_di_mat - N x n_gamma
		 var_di_mat = t(sapply(1:N, function(x)
		 apply( outer(lambda_array_squared[x, , ], rep(1, n_gamma)) * var_gamma_array, 3, sum, na.rm = TRUE)
		 ))
		 se_array[ , ,i] = sqrt(var_di_mat)
		 z_array[ , ,i] = matrix(di_vec, nrow = N, ncol = n_gamma, byrow = FALSE) / se_array[ , ,i]
		}

	return(
		list( D = d_mat, O = o_mat, E = e_mat, Z = z_array,
				SE = se_array)	)
}


############################################################
############################################################
######            ROC/PRC based on re         ##############
############################################################
############################################################

# Author: Yue Zhang
# Create date: 05/Aug/2018
# Contact: yue.zhang@lih.lu

reAUC <- re[,c(-2,-4)]

nnumber <- 500
TPR <- rep(0,nnumber)
FPR <- rep(0,nnumber)
precision <- rep(0,nnumber)
cutpoint <- rep(0,nnumber)

p <- which(reAUC$Original == "RES")
n <- which(reAUC$Original == "SEN")
### Calculate the TPR/FPR

for(i in 1:nnumber){
  cutpoint[i] <- as.numeric(i/nnumber)
  predictionR <- reAUC$Pred_RES > cutpoint[i]
  pp <- intersect(which(predictionR == TRUE),p)   ### TP
  fp <- intersect(which(predictionR == TRUE),n)  ### Number of FP
  TPR[i] <- length(pp)/length(p)
  FPR[i] <- length(fp)/length(n)
  precision[i] <- length(pp)/length(which(predictionR == TRUE))
}

### Calculate the AUC

pos.value <- reAUC$Pred_RES[which(reAUC$Original == "RES")]
neg.value <- reAUC$Pred_RES[which(reAUC$Original == "SEN")]

aucs1 <- replicate(2000,mean(sample(pos.value,1000,replace = T) > sample(neg.value,1000,replace = T)))
auc <- round(mean(aucs1),4)

plotready <- cbind(FPR,TPR,precision)
colnames(plotready) <- c("FPR","TPR","precision")

plotready <- as.data.frame(plotready)

ROCc <- ggplot(plotready, aes(x = FPR,y = TPR))+
  geom_path(color = "red", size = 2)+
  geom_abline(intercept = 0, slope = 1, color='grey',size = 0.7)+
  theme_bw()+
  ggtitle(paste0("ROC curve, AUC = ", auc))

PRCc <- ggplot(plotready, aes(y = precision,x = TPR))+
  geom_path(color = "red", size = 2)+
  theme_bw()+
  ggtitle("PRC curve")


# Osnovni tipovi

# numeric
x <- 10.5
x
class(x)
y <- 4
class(y)
class(x+y)
is.numeric(x)

x <- as.numeric("62e-2")
x
x <- as.numeric( "six")
x
x <- as.numeric(TRUE)
x
x <- as.numeric(FALSE)
x
x <- as.numeric("FALSE")
x

#integer
x <- 4
is.integer(x)
y <- 4L
class(y)
is.integer(y)
class(x + y)
z <- as.integer(x)
class(z)
class(y+z)

x <- as.integer(4.13)
x
x <- as.integer(4.83)
x
x <- as.integer( round(4.83) )
x
x <- as.integer( "6")
x
x <- as.integer( "6.3")
x
x <- as.integer( "6.99")
x
x <- as.integer( "six")
x

# complex
x <- 2 + 3i
x
y <- 4+ 2i
y
z <- x + y
z
t <- x * y
t
class(x)

minus.1 <- as.complex(-1) # -1+0i
class(minus.1)
imaginarna.jedinica <- sqrt(minus.1)
imaginarna.jedinica

x <- as.complex( TRUE )
x
x <- as.complex( "434e1" )
x
x <- as.complex( "2+3i")
x

# logical
x <- 1; y <- 2
z <- x < y
z
class(z)

x <- TRUE
y <- FALSE
z <- x & y
z
t <- x | y
t
u <- !x
x
v <- !y
v

# character
x <- "Dobro vece!"
x
class(x)

x <- 12
y <- as.character(x)
y
x <- 12.43E1
y <- as.character(x)
y
x <- FALSE
y <- as.character(x)
y

x <- "Dobro"
y <- "vece"
z <- paste(x, y)
z
t <- paste(x, y, "dobri ljudi!")
t

# funkcija sprintf
x <- sprintf("Pevac %s ima %d hitova", "Zdravko Colic", 15)
x
pevac <- "Zdravko Colic"
broj <- 19
x <- sprintf("Pevac %s ima %d hitova", pevac, broj)
x

# funkcija substr - izdvajanje podniske iz niske
x <- "Ovo je jedna pametna recenica."
y <- substr(x, 5,10)
y
y <- substr(x, stop = 10, start = 5)
y

# funkcija sub - zamenjuje pdnisku sa drugom niskom
x <- "Ovo je jedna pametna recenica."
y <- sub( "pametna", "glupa", x)
y

# Vektori
x <- c(7,2,3,4)
x
x <- c(7L, 2L, 3L, 4L)
x
x <- c(7L, 2L, 3, 4L)
x
x <- c(7+2i, 2L, 3, 4L)
x
x <- c(7+2i, "2L", 3, 4L)
x


library(ggplot2)
setwd("/Users/VGupta/Documents/Research/Julia Stuff/Demand")
d1 = read.csv("fit1_Demand.csv", header=TRUE)
dk1 = read.csv("fit1_Kernel.csv", header=TRUE)
d1 = data.frame(d1, Kernel=dk1$Fit, LB=dk1$LB, UB=dk1$UB, Sample=dk1$Sample)

ggplot(aes(x=Prices, y=MargRev), data=d1) +
  geom_line(size=.5, linetype="dashed") +
  geom_point(aes(y=Fit), color="red", size=3 ) +
  geom_line(aes(y=Fit), color="red" ) +
  geom_ribbon(aes(ymin=LB, ymax=UB), fill="grey", alpha=.5)+
  geom_line(aes(y=Kernel), linetype="dotted", size=.5, color="black") +
  geom_point(aes(y=Kernel), color="black", fill="black", shape=15, size=3) +
  theme_bw(base_size=18) +
  ylab("Marginal Revenue") + xlab("Firm 1 Prices")

d2 = read.csv("fit2_Demand.csv", header=TRUE)
dk2 = read.csv("fit2_Kernel.csv", header=TRUE)
d2 = data.frame(d2, Kernel=dk2$Fit, LB=dk2$LB, UB=dk2$UB, Sample=dk2$Sample)

ggplot(aes(x=Prices, y=MargRev), data=d2) +
  geom_line(size=.5, linetype="dashed") +
  geom_point(aes(y=Fit), color="red", size=3 ) +
  geom_line(aes(y=Fit), color="red" ) +
  geom_ribbon(aes(ymin=LB, ymax=UB), fill="grey", alpha=.5)+
  geom_line(aes(y=Kernel), linetype="dotted", size=.5, color="black") +
  geom_point(aes(y=Kernel), color="black", fill="black", shape=15, size=3) +
  theme_bw(base_size=18) +
  ylab("Marginal Revenue") + xlab("Firm 2 Prices")

#### Straightup out-of-sample residuals
resids = read.csv("DemandResids.csv")
names(resids)
ggplot(aes(x=x2), data=resids) +
  geom_histogram(aes(y=..density..), fill="grey") +
  xlab("Approximation Error") + ylab("") +
  geom_vline(xintercept = 1.0630507131067428, linetype="dotted") +
  theme_bw(base_size=18)

mean(resids$x2 < 1.06305)

##### The idealized problem #####
dat1.ideal = read.csv("fit1_idealized.csv")
dat2.ideal = read.csv("fit2_idealized.csv")
colnames(dat2.ideal)<- colnames(dat1.ideal)

ggplot(aes(x=Prices, y=True), data=dat2.ideal) +
  geom_line(size=.5, linetype="dashed") +
  geom_point(aes(y=Fit), color="black", size=3, shape=15) +
  geom_line(aes(y=Fit), color="black", size=.5) +
  ylab("Marginal Revenue") +
  geom_line(aes(y=Sample), linetype="dotted", size=.5, color="black") +
  geom_point(aes(y=Sample), color="blue", shape=17, size=3) +
  geom_ribbon(aes(ymin=LB, ymax=UB), fill="grey", alpha=.3) +
  coord_cartesian(ylim=c(-10, 6)) +
  xlab("Firm 2 Price") +
  theme_bw(base_size=18)


#!/usr/bin/env Rscript
# Command syntax:
#	regression-part.r [--noheader] [-s start] filename.csv
# CSV file must be in one of two formats:
#	independent,dependent
#	index,independent,dependent
# CSV header is optional

args <- commandArgs()
start <- FALSE
h <- TRUE # CSV file has header?
for( arg in args ){
	if( arg == "--noheader" ){
		h <- FALSE
	}
	else if( arg == "-s" ){
		start <- TRUE
	}
	else if( start == TRUE ){
		start <- as.numeric( arg )
	}
	else{
		f <- arg
	}
}
data <- read.csv( f, header = h )
fields <- colnames( data ) # Used for labeling axes
if( ncol( data ) == 2 ){ # No index field
	colnames( data ) <- c( "x", "y" )
}
if( ncol( data ) == 3 ){ # Index field
	colnames( data ) <- c( "x", "q", "y" )
}
data_for_lm <- subset( data, data$x >= start )
lm.data <- lm( y ~ x, data )
if( start != FALSE ){
	lm.data_for_lm <- lm( y ~ x, data_for_lm )
}
plot( data$x, data$y, col = "#0000ff", type = "n", pch = 19,
      # I got an error message if I didn't supply xlim and ylim
      xlim = c( min( data$x ), max( data$x ) ),
      ylim = c( min( data$y ), max( data$y ) ),
      xlab = fields[ncol( data )-1],
      ylab = fields[ncol( data )]  )
lines( data$x, data$y, col = "#0000ff", type = "o" )
abline( lm.data, col="#ff0000" )
if( start != FALSE ){
	abline( lm.data_for_lm, col="#00bb00" )
	print( "Regression for entire data set:" )
}
lm.data # Print slope and intercept
if( start != FALSE ){
	print( "Regression for partial data set:" )
	lm.data_for_lm
}


#' Find and report naive gene gene correlation over umi matrix
#'
#' The generated table should be the basis for manual curation usually, and can be used to generate supervised gene sets, or a basis for them
#'
#' @param mat_id matrix to use
#' @param gene_anchors genes that will be used as anchors for computing correlation against all other genes
#' @param gene_anti genes that will be used as negative anchors - high correlation to these will be considered negatively
#' @param cor_thresh correlation threshold (on downsampled data) - the table will include genes with maximal correlation higher than the threshold, AND, maximal correlation for negative anchor lower than for positive nachors
#' @param tab_fn file name of tabular report
#' @export
#'

mcell_mat_rpt_cor_anchors = function(mat_id, gene_anchors, gene_anti = c(), cor_thresh, tab_fn, sz_cor_thresh = NA, downsample_n = NA, cells = NULL)
{
	mat = scdb_mat(mat_id)
	if(is.null(mat)) {
		stop("missing mat ", mat_id)
	}

	if(!is.null(cells)) {
		umis = mat@mat[,cells]
	} else {
		umis = mat@mat
	}

	if(is.na(downsample_n)) {
		downsample_n = quantile(colSums(umis), 0.05)
	}

	mat_ds = scm_downsamp(umis, downsample_n)
	mat_ds = mat_ds[rowSums(mat_ds)>10,]

	gene_exists = gene_anchors %in% rownames(mat_ds)
	if (any(!gene_exists)) {
		warning(gene_anchors[!gene_exists], " does not exist in the downsampled matrix (it has less than 10 UMIs)")
	}

	gene_anchors = gene_anchors[gene_exists]

	csize = colSums(mat@mat[,colnames(mat_ds)])
	gcors = data.frame(sz_cor = apply(mat_ds, 1, cor, csize))
	for(g in gene_anchors) {
		gcors[,g] = apply(mat_ds, 1, cor, mat_ds[g,])
	}
	for(g in gene_anti) {
		gcors[,g] = apply(mat_ds, 1, cor, mat_ds[g,])
	}
	N1 = length(gene_anchors) + 1
	N2 = N1 + length(gene_anti)

	if(length(gene_anchors) == 1) {
		gcors$max = gcors[,2]
	} else {
		gcors$max = apply(gcors[,2:N1], 1, max)
	}
	if(length(gene_anti) == 0) {
		gcors$neg_max = 0
	} else if(length(gene_anti) == 1) {
		gcors$neg_max = gcors[,N2]
	} else {
		gcors$neg_max = apply(gcors[,(N1+1):N2], 1, max)
	}
	f = !is.na(gcors$max) & gcors$max > cor_thresh & gcors$max > gcors$neg_max
	if(!is.na(sz_cor_thresh)) {
		f = f | (gcors$sz_cor > sz_cor_thresh)
	}
	write.table(gcors[f ,], tab_fn, sep="\t", quote=F)
}


library(terra)
library(sf)
dem = rast("data/dem.tif")
riv = st_read("output/neretva.gpkg")
neretva = rast("output/neretva.grd")
dem = crop(dem, neretva)

# pts = data.frame(name = c("dam", "ds_sample", "source"),
# 	x = c(17.762885, 17.962372, 18.552181), y = c(43.655467, 43.651676, 43.283714))
# pts = st_transform(st_as_sf(pts, coords = c('x', 'y'), crs = 4326), crs = 3035)
# pts = rbind(pts, st_as_sf(data.frame(name = "outlet", x = 4945013, y = 2308310),
# 	coords = c('x', 'y'), crs = 3035))
sl = terrain(dem, unit = "radians")
as = terrain(dem, "aspect", unit = "radians")
hs = shade(sl, as)

ptcol = "#ffcc66"
rivcol = "#0099ff"

jpeg(width=2000, height = 2000, file = "output/neretva.jpg")
## catch a weird R-internal error that pops up sometimes
tryCatch(
	plot(hs, col=grey(0:100/100), alpha = 1, legend = FALSE, axes = FALSE),
	error = function(e) print(e))
plot(dem, add = TRUE, alpha = 0.6, col = terrain.colors(100),
	axes = FALSE, legend=FALSE)
plot(neretva$catchment, add = TRUE, alpha = 0.5, col = "#c3e4e3", axes = FALSE, legend = FALSE)
plot(st_geometry(riv), col=rivcol, lwd=riv$order, add = TRUE)
# plot(st_geometry(pts), col=ptcol, pch=16, add = TRUE, cex=2)
# text(st_coordinates(pts)[,1], st_coordinates(pts)[,2], pts$name, pos=4, col = ptcol, cex=1.5)
dev.off()


options(stringsAsFactors = FALSE)

library('dplyr')
library('sleuth')
library('ggplot2')
library('splines')

s2c <- read.csv("ConstantLight.csv", header = TRUE, stringsAsFactors = FALSE)

library(splines)
timepoint <- s2c$timepoint
full_design <- model.matrix(formula(~ ns(timepoint, df = 5)))
full_design

so <- sleuth_prep(s2c, full_model = full_design,)
so <- sleuth_fit(so)
so <- sleuth_fit(so, formula = ~ 1, fit_name = "reduced")
so <- sleuth_lrt(so, "reduced", "full")

Normalized_counts <- sleuth_to_matrix(so, 'obs_norm', 'est_counts')

write.csv(Normalized_counts, file = "Normalized.counts.csv")

lrt_results <- sleuth_results(so, 'reduced:full', test_type = 'lrt')

table(lrt_results[,"qval"] < 0.05)

lrt_results %>% head(n = 20) %>% dplyr::select(target_id, qval)

tmp <- so$obs_raw %>% dplyr::filter(target_id == 'Mp1g00050.1')
tmp <- dplyr::full_join(so$sample_to_covariates, tmp, by = 'sample')
tmp

tmp <- transform(tmp, timepoint = as.numeric(timepoint))
(ggplot(tmp, aes(x=timepoint, y=est_counts))
  + geom_point(shape=1)
  + geom_smooth(method = loess))

plot_transcript_heatmap(so, head(lrt_results, n = 20)$target_id, 'est_counts')
plot_qq(so, test = 'reduced:full', test_type = 'lrt', sig_level = 0.05)


suppressMessages(library(Seurat))

fn = "data/H1_day0_scranNorm_adtbatchNorm.rds"
h1 = readRDS(fn)

# specify levels of protein to cluster, remove proteins that didnt stain.
prot = rownames(h1@assay$CITE@data)
prot_subset = prot[-c(83:86)]

# Subset normalized protein 3 levels.
h1_adt = GetAssayData(h1, assay.type = "CITE", slot = "data")

# subset used markers
h1_adt3 = h1_adt[prot_subset, ]

# get distance matrix
p3_dist = dist(t(h1_adt3))
p3_dist = as.matrix(p3_dist)

# cluster
res = c(0.1, 0.3, 1, 3.0)
for (i in 1:length(res)) {
  cat(res[i]," ")
  h1 = FindClusters(h1,
  					distance.matrix = p3_dist,
  					k.param = 50,
                    print.output = F,
                    resolution = res[i],
                    random.seed = 1,
                    algorithm = 3,
                    modularity.fxn = 1)
  h1 = StashIdent(h1, save.name = paste0("p3_dist_",i))

  saveRDS(h1@meta.data, "data/H1N1_full_clustered_p3dist_multires_metadata.rds")
}

# Add clusters to the original object. (The new object stores the distance matrix and is very large to be saved.)

h1_md = h1@meta.data
h1 = readRDS(fn) # reread the original object
h1 = AddMetaData(h1, metadata = h1_md)
fn.new = "data/H1_day0_scranNorm_adtbatchNorm_dist_clustered.rds"
saveRDS(h1, fn.new)


mvd.rgen <- function(fit, n) {
    stopifnot(class(fit) == "mvd.density")

    if (fit$type == "kde") {
        s <- sample(nrow(fit$x), n, replace = T)

        #if (all(fit$H[!diag(nrow(fit$H))] == 0)) {
        #    for (i in 1:n) {
        #        x[i,] <- rnorm(ncol(fit$x), fit$x[s[i],], diag(fit$H))
        #    }
        #} else {
            x <- mvtnorm::rmvnorm(n, rep(0, ncol(fit$x)), fit$H)
            x <- x + fit$x[s,]
        #}
    } else if (fit$type == "kde.transformed") {
        transformed <- mvd.rgen(fit$kde, n)
        x <- mvd.transform_from_unbounded(transformed, fit$transform.bounds)
    } else if (fit$type == "gmm") {
      s <- sample(fit$k, n, replace = T)
      for (i in 1:n) {
        x[i,] <- mvtnorm::rmvnorm(1, fit$centers[s[i],], fit$covariances[[s[i]]])
      }
    } else if (fit$type == "gmm.transformed") {
      transformed <- mvd.rgen(fit$gmm, n)
      x <- mvd.transform_from_unbounded(transformed, fit$transform.bounds)
    } else if (fit$type == "gmm.truncated") {
      if (ncol(x) < 10) {
        method <- "rejection"
      } else {
        method <- "gibbs"
      }
      s <- sample(fit$k, n, replace = T)
      for (i in 1:n) {
        x[i,] <- tmvtnorm::rtmvnorm(1, fit$centers[s[i],], fit$covariances[[s[i]]], fit$bounds[,1], fit$bounds[,2], algorithm=method)
      }
    } else if (fit$type == "mfa") {
      x <- EMMIXmfa::rmix(n, fit$mfa_res)
    }else if (fit$type == "mfa.transformed") {
      transformed <- mvd.rgen(fit$mfa, n)
      x <- mvd.transform_from_unbounded(transformed, fit$transform.bounds)
    } else if (fit$type == "gp") {
      stop("Cannot sample from density function described by gaussian process")
    } else if (fit$type == "vine.copula") {
      sim <- VineCopula::RVineSim(n, fit$RVM)
      x <- reverse.transform.marginals(sim, fit$marginal)
    } else {
      stop("Unknown type")
    }

  return(x)
}


nextState <- function(x, y, wx, wy, inp) {
    cmd <- substring(inp, 1, 1)
    val <- strtoi(substring(inp, 2, nchar(inp)))

    result <- switch(cmd,
        "N" = move_w(x, y, wx, wy, "N", val),
        "S" = move_w(x, y, wx, wy, "S", val),
        "E" = move_w(x, y, wx, wy, "E", val),
        "W" = move_w(x, y, wx, wy, "W", val),
        "F" = move_f(x, y, wx, wy, val),
        "R" = rotate_v(x, y, wx, wy, -val),
        "L" = rotate_v(x, y, wx, wy, val))

    result
}

move_w <- function(x, y, wx, wy, moveDir, val) {
    switch(moveDir,
        "N" = c(x, y, wx, wy + val),
        "S" = c(x, y, wx, wy - val),
        "E" = c(x, y, wx + val, wy),
        "W" = c(x, y, wx - val, wy))
}

move_f <- function(x, y, wx, wy, count) {
    c(x + wx * count, y + wy * count, wx, wy)
}

rotate_v <- function(x, y, wx, wy, d) {
    r <- d * (pi / 180)

    c(x, y, wx * cos(r) - wy * sin(r), wx * sin(r) + wy * cos(r))
}

fileName <- "input.txt"

x <- 0
y <- 0

wx <- 10
wy <- 1

inp <- file(fileName, "r")

for (line in readLines(inp)) {
    s <- nextState(x, y, wx, wy, line)

    x <- round(as.double(s[1]))
    y <- round(as.double(s[2]))
    wx <- round(as.double(s[3]))
    wy <- round(as.double(s[4]))
}

close(inp)

print(abs(x) + abs(y))


# Simulate VB tag-recapture, otolith and length-frequency growth data
# =====================================================================

# Specify VB parameters common to all datasets(noting that Linf ~ Norm(mu.Linf, sigma.Linf) )
k <- 0.2
a0 <- 0
mu.Linf <- 100
sigma.Linf <- 5

# a)tag-recapture data:
# ----------------------
set.seed(1)
n <- 500

# generate log-normal release ages (relative to a0)
par1.A <- 0.5
par2.A <- 0.3
A <- rlnorm(n,par1.A,par2.A)

# generate times at liberty assuming gamma distribution
dt <- rgamma(n,3,.5)

# generate release lengths and recapture lengths assuming random Linf and measurement error
Linf <- rnorm(n,mu.Linf,sigma.Linf)
sig.tag <- 5
L1 <- Linf*(1-exp(-k*A)) + rnorm(n,0,sig.tag)
L2 <- Linf*(1-exp(-k*(A+dt))) + rnorm(n,0,sig.tag)

# Note that the code allows for a different measurement error for scientist-measured recapture lengths
# versus fisherman-measured recapture lengths, so need to specify whether L2 was measured by
# a scientist (=0) or a fisherman (=1).  Here I'll specify all as scientist (0) since I generated L2
# assuming the same measurement error for all observations.
L2measurer <- rep(0,n)

tagdat <- cbind(L1,L2,rep(0,n),dt,L2measurer)
plot(c(A,A+dt),c(L1,L2),xlab="age",ylab="length")
points(A,L1,col=2)

# b) otolith data:
# ----------------------
set.seed(1)
n.oto <- 200

# generate random uniform ages
age <- runif(n.oto,.5,20)
# generate corresponding lengths with measurement error
Linf <- rnorm(n.oto,mu.Linf,sigma.Linf)
sig.oto <- 5
len <- Linf*(1-exp(-k*(age-a0))) + rnorm(n.oto,0,sig.oto)

otodat <- cbind(age,len)
points(age,len,pch=2,col=3)

# c) length-frequency data:
# -------------------------
set.seed(1)

# Note: the LF component assumes that a model decomposition has already been applied to the
# raw data, such that the dataset input to the growth analysis is the ages and lengths corresponding to
# the modes in the LF data, along with the standard error estimates for each modal length estimate

# generate ages and lengths corresponding to modes in the LF data, assuming we have monthly LF data for
# fish of ages 1-5, and we have this data for 5 years
mode.age <- rep(seq(1,5,1/12),times=5)
n.lf <- length(mode.age)
# recall we are not including a random Linf parameter for the LF data
sig.lf <- 5
mode.len <- mu.Linf*(1-exp(-k*(mode.age-a0))) + rnorm(n.lf,0,sig.lf)

# Specify standard error estimates corresponding to each of the modal length estimates
se.mode <- rlnorm(n.lf,.01,.5)

lfdat <- cbind(mode.age,mode.len,se.mode)
points(mode.age,mode.len,pch=3,col=4)

# Source the R code with the likelihood and a range of growth functions:
# -----------------------------------------------------------------------
source("/Users/stephenscherrer/Google Drive/Weng Lab/Data/Bottomfish/Okamoto's 1990s Mark Recapture Data/src/Laslett Functions/joint_lkhd.r")
source("/Users/stephenscherrer/Google Drive/Weng Lab/Data/Bottomfish/Okamoto's 1990s Mark Recapture Data/src/Laslett Functions/growth_functions.r")

# Fit a VB model WITHOUT seasonal growth:
# -----------------------------------------
growth.ssnl.f<- growthvb.f
npf <- 1  #number of parameters passed to growth.ssnl.f (in this case k)
npA <- 2  #number of parameters in distribution of release ages for tag model

# specify starting parameters, as well as upper and lower bounds
#        mu.L, sig.L,   k,  mu.A, sig.A, sig.sci, sig.f, a0, sig.oto, sig.lf
p0 <- c(  70,   5.0, .10,   1.0,   .10,    5.0,      0,  0,   10.0,   10.0)
lb <- c(   50,   1.0, .05,    .1,   .05,    1.0,      0, -2,    0.0,    0.0)
ub <- c(  100,  15.0, .40,   1.5,   .50,   10.0,      0,  1,   15.0,   15.0)
fit.vb <- nlminb(p0,joint.logl.f,lower=lb,upper=ub,npf=npf,npA=npA,tagdat=tagdat,otodat=otodat,lfdat=lfdatz)
fit.vb

# Fit a VB model *WITH* seasonal growth:
# -----------------------------------------
growth.ssnl.f<- growthvb.ssnl.f
npf <- 3  #number of parameters passed to growth.ssnl.f (in this case k, u, w)
npA <- 2  #number of parameters in distribution of release ages for tag model

# specify starting parameters, as well as upper and lower bounds
#        mu.L, sig.L,   k,  u,   w, mu.A, sig.A, sig.sci, sig.f, a0, sig.oto, sig.lf
p0 <- c(  110,   5.0, .10, .1,   0,  1.0,   .10,    5.0,      0,  0,   10.0,   10.0)
lb <- c(   70,   1.0, .05,  0, -.5,   .1,   .05,    1.0,      0, -2,    0.0,    0.0)
ub <- c(  130,  15.0, .40,  1,  .5,  1.5,   .50,   10.0,      0,  1,   15.0,   15.0)
fit.ssnl.vb <- nlminb(p0,joint.logl.f,lower=lb,upper=ub,npf=npf,npA=npA,tagdat=tagdat,otodat=otodat,lfdat=lfdat)
fit.ssnl.vb


###############################
###  2009, David Ellinghaus ###
###############################

rm(list=ls())

file.results   <- commandArgs()[4]
disease_name   <- commandArgs()[5]

gwas <- read.table(file.results,header=T,stringsAsFactor=F)

# manhattan
gwas <- gwas[order(gwas$CHR),]
pos.plot <- cpos.abs<-as.numeric(gwas$BP)
cpos.min <- tapply(as.numeric(gwas$BP),gwas$CHR,min)
cpos.max <- tapply(as.numeric(gwas$BP),gwas$CHR,max)
cpos.max.abs <- cpos.max-cpos.min

pos.plot[gwas$CHR==1] <- pos.plot[gwas$CHR==1]-cpos.min[1]+1
for(i in 2:22)
{
  c.ind <- gwas$CHR==i
  pos.plot[c.ind==T] <- sum(cpos.max[1:(i-1)])+pos.plot[c.ind==T]-cpos.min[i]+1
}
#colplot <- ifelse(gwas$CHR%in%c(2,4,6,8,10,12,14,16,18,20,22),grey(.5),grey(.3))
colplot <- ifelse(gwas$CHR%in%c(2,4,6,8,10,12,14,16,18,20,22),"darkblue","lightblue")

jpeg(file=paste(file.results, ".manhattan.jpg", sep=""), quality=100,width=1600,height=700)
plot(pos.plot,-log10(gwas$P),col=colplot,ylab="-log10(p)", xlab="Chromosome",xaxt="n",pch=20,las=1,cex=1.5, main=paste( disease_name, sep=" "))
# ,ylim=c(0,7)
lab.pos <- tapply(pos.plot,gwas$CHR,mean)
axis(1, at=lab.pos, labels=1:22)
axis(2, at=seq(0,40,5), las=1)

genomewideline=-log10(5e-8)
abline(h=genomewideline, col="red", lty=5)
text(500000000, genomewideline + 0.05, labels=c("genome-wide significance"),
    pos=3, cex=1.0, col="red")

dev.off()


#' Profile heat map plot
#'
#' Plots a lake profile heatmap for a single site and parameter.
#' @param data Lake profile data (wide format)
#' @param date Date column name. Must be in 'YYYY-mm-dd' format.
#' @param parameter Column name for parameter to be used as z-values.
#' @param param_units Character. Parameter units. Used to plot build label.
#' @param param_lab Character. Label to be used for parameter name. Used to build plot label.
#' @param depth Column name for depth column.
#' @param depth_units Character. Depth units. Used to plot build label.
#' @param min_date Minimum plot date. 'YYYY-mm-dd' format.
#' @param max_date Maximum plot date. 'YYYY-mm-dd' format.
#' @param show_dates Logical. If TRUE (default), show individual profile dates on plot x-axis.
#' @param criteria Vector of criteria values to be used as contours on heatmap plot. If not specified, contours from 0-30 at increments of 5 are drawn.
#' @importFrom akima interp
#' @importFrom lubridate origin

#' @export
profileHeatMap=function(data, parameter, depth="Depth_m", param_units, depth_units="m", date="ActivityStartDate", show_dates=TRUE, min_date=min(data[,date], na.rm=T), max_date=max(data[,date], na.rm=T), param_lab="pH", criteria){

	##############
	#load("assessed_profs.rdata")
	#data=assessed_profs$profiles_wide[assessed_profs$profiles_wide$IR_MLID=="UTAHDWQ_WQX-5914010",]
	#data$ActivityStartDate=as.Date(data$ActivityStartDate)
	#date="ActivityStartDate"
	#parameter="DO_mgL"
	#param_units="deg C"
	#param_lab="Temperature"
	#depth="Depth_m"
	#depth_units="m"
	#show_dates=TRUE
	#min_date=min(data[,date], na.rm=T)
	#max_date=max(data[,date], na.rm=T)
	#criteria=c(20,27)
	#profileHeatMap(assessed_profs$profiles_wide[assessed_profs$profiles_wide$IR_MLID=="UTAHDWQ_WQX-5914010",],parameter="Temp_degC",param_units="deg C",param_lab="Temperature",depth="Depth_m",depth_units="m")
	##########

	data[,date]=as.Date(data[,date])
	if(missing(criteria)){criteria=c(0,10,15,20,25,30)}
	data=data[!is.na(data[,parameter]) & !is.na(data[,depth]),]

		int=akima::interp(data[,date],data[,depth],data[,parameter],duplicate="strip",linear=TRUE)

		if(param_units!=""){title=paste0(param_lab," (",param_units,")")}else{title=param_lab}

		if(show_dates==TRUE){
			par(mar=c(8.1,4.1,4.1,2.1))
			filled.contour(int,color.palette=topo.colors,xlim=c(min_date-1,max_date+1),ylim=rev(range(data[,depth])),
				ylab=paste0("Depth (",depth_units,")"), main=title,
				plot.axes = { contour(int, levels = criteria, lwd=2, col="red", drawlabels = TRUE, axes = FALSE, frame.plot = FALSE, add = TRUE, labcex=2);
										axis(1,at=unique(data[,date]),labels=unique(data[,date]),par(las=2)); axis(2) } )

		}else{
			filled.contour(int,color.palette=topo.colors,xlim=c(min_date-1,max_date+1),ylim=rev(range(data[,depth])),
				ylab=paste0("Depth (",depth_units,")"), main=title,
				plot.axes = { contour(int, levels = criteria, lwd=2, col="red", drawlabels = TRUE, axes = FALSE, frame.plot = FALSE, add = TRUE, labcex=2);
					axis.Date(side=1,x=as.Date(int$x,origin=lubridate::origin)); axis(2) } )}

}


y=1
digital_root=function(n){
  x=sum(as.numeric(unlist(strsplit(as.character(n),""))))
  if(x<10){
    k=x
  }else{
    y=y+1
    assign("y",y,envir = globalenv())
    k=digital_root(x)
  }
  return(k)
}
print("Given number has additive persistence",y)


# Chi-square test
#'
#' @importFrom stats chisq.test
#' @importFrom stats fisher.test
#' @importFrom rlang f_rhs
#'
chi2test <- function(baseline = NULL,
                     data = NULL,
                     treat_levels = NULL,
                     treat_labels = NULL,
                     ctrl = NULL,
                     subset = NULL,
                     test_type = "f",
                     fisher = FALSE,
                     bootp = FALSE) {
  # clean data
  treat <- reorder_arms(treat_levels, treat_labels, ctrl)
  use <- clean_RCTdata(
    baseline,
    data = data,
    treat_levels = treat$levels,
    treat_labels = treat$labels,
    subset = subset
  )

  # design matrix without intercept
  dmat <- use$design[, -1]
  dvar <- as.character(f_rhs(baseline))

  # ctrl data
  ctrl <- as.logical(1 - rowSums(dmat))
  y0 <- use$outcome[ctrl]

  # condition of test_type
  if (test_type == "t") {
    res <- apply(dmat, 2, function(x) {
      # create cross-tabulation
      treated <- as.logical(x)
      y1 <- use$outcome[treated]
      y <- c(y1, y0)
      d <- c(
        rep_len("Treat", length(y1)),
        rep_len(treat$labels[1], length(y0))
      )
      tab <- table(y, d)

      # fisher or chi-squared test
      if (nrow(tab) == 1 | ncol(tab) == 1) {
        message(paste(
          "Either number of cols or rows of cross-tabulation is one;",
          "Chi-squared test or fisher exact test is not performed. Return NA."
        ))
        pval <- NA_real_
      } else {
        if (fisher) {
          pval <- fisher.test(tab, simulate.p.value = bootp)$p.value
        } else {
          pval <- chisq.test(tab)$p.value
        }
      }

      # output
      list(tab = tab, p = pval)
    })

    names(res) <- gsub(dvar, "", names(res))
    res

  } else if (test_type == "f") {
    # create cross-tabulation
    vector_y1 <- apply(dmat, 2, function(x) {
      treated <- as.logical(x)
      use$outcome[treated]
    })
    vector_d1 <- lapply(names(vector_y1), function(x) {
      rep_len(gsub(dvar, "", x), length(vector_y1[[x]]))
    })
    y <- c(y0, unlist(vector_y1))
    d <- c(rep_len(treat$labels[1], length(y0)), unlist(vector_d1))
    tab <- table(y, d)

    # fisher or chi-squared test
    if (nrow(tab) == 1 | ncol(tab) == 1) {
      message(paste(
        "Either number of cols or rows of cross-tabulation is one;",
        "Chi-squared test or fisher exact test is not performed. Return NA."
      ))
      pval <- NA_real_
    } else {
      if (fisher) {
        pval <- fisher.test(tab, simulate.p.value = bootp)$p.value
      } else {
        pval <- chisq.test(tab)$p.value
      }
    }

    # output
    list(tab = tab, p = pval)
  } else {
    abort_invalid_input("test_type", test_type, '"t" or "f')
  }
}

# Chi-square test with multi baseline model
#'
#' @importFrom rlang enexpr
#' @importFrom rlang f_lhs
#'
chi2test_multi_mod <- function(baseline = NULL,
                               data = NULL,
                               treat_levels = NULL,
                               treat_labels = NULL,
                               ctrl = NULL,
                               subset = NULL,
                               test_type = "f",
                               fisher = FALSE,
                               bootp = FALSE) {
  # list of baseline models
  if (!is.list(baseline)) baseline <- list(baseline)

  # run chi2test
  res <- lapply(
    baseline,
    chi2test,
    data,
    treat_levels,
    treat_labels,
    ctrl,
    enexpr(subset),
    test_type,
    fisher,
    bootp
  )

  # output
  labs <- lapply(baseline, function(m) as.character(f_lhs(m)))
  names(res) <- labs
  list(
    result = res,
    method = list(type = test_type, fisher = fisher)
  )
}


#' @title calcHMPwr
#'
#' @description Calculate instantaneous main engine power (kW) using the Holtrop & Mennen method.
#'
#' @param totalInstalledPwr Total installed main engine power (vector of numericals, kW) (maximum
#' continuous rated power)
#' @param shipSpeed Ship actual speed (vector of numericals, m/s) (see
#'  \code{\link{calcSpeedUnitConversion}})
#' @param actualDraft Actual draft (vector of numericals, m)
#' @param maxDraft Maximum summer load line draft (vector of numericals, m)
#' @param shipType Ship type (vector of strings, see \code{\link{calcShipType}}).
#' Must align with \code{tankerBulkCarrierShipTypes}, \code{tugShipTypes},
#' \code{roroPaxShipTypes}, \code{gCargoShipTypes},
#' \code{containerShipTypes} groupings
#' @param lwl Waterline length (vector of numericals, m) (see \code{\link{calclwl}})
#' @param breadth Moulded breadth (vector of numericals, m)
#' @param maxDisplacement Maximum ship displacement (vector of numericals, m^3)
#' @param Cb Maximum block coefficient (vector of numericals, dimensionless) (see
#' \code{\link{calcCb}})
#' @param nProp Number of propellers (vector of numericals, see \code{\link{calcPropNum}})
#' @param serviceMargin A service margin to account for weather and sea effects:
#' \itemize{\item At-sea operations = 15 (Default) \item Coastal operations = 10} Can
#' supply either a vector of numericals, a single number, or rely on the default
#' @param shaftEff Shaft efficiency (dimensionless). Default = 0.98.
#'  Ratio of power delivered to the propeller and the brake power delivered by
#'  the engine. Can supply either a vector of numericals, a single number, or rely on the default.
#' @param relRotationEff Relative rotational efficiency (dimensionless).
#'  Default = 1. Accounts for effect of rotational flow of water around propeller.
#' Can supply either a vector of numericals, a single number, or rely on the default
#' @param seawaterTemp Sea water temperature. Default = 15 (degrees Celsius). Can
#' supply either a vector of numericals, a single number, or rely on the default
#' @param seawaterDensity Sea water density. Default = 1.025 (g/cm^3). Can
#' supply either a vector of numericals, a single number, or rely on the default
#' @param pwrUpperBoundPercent Percent of total installed power at which
#' required power is capped. Default = 1, which indicates required power cannot
#' exceed \code{totalInstalledPwr}. Can supply either a vector of numericals, a
#' single number, or rely on the default
#' @param pwrLowerBoundPercent Percent of total installed power to act as lower
#' bound for required power. Default = 0.02, which indicates required power
#' cannot go below 2\% of \code{totalInstalledPwr}. Can supply either a vector
#' of numericals, a single number, or rely on the default
#' @param CmEquationType Type of equation to estimate the midship section
#' coefficient (see \code{\link{calcCm}}): \itemize{
#' \item"kristensen (Default)"
#' \item"benford"
#' \item"schneekluth"}
#' This argument is not vectorized, as it takes only a single string
#' @param tankerBulkCarrierShipTypes Ship types specified in input
#' \code{shipTypes} to be modeled as tankers and bulk carriers
#' @param tugShipTypes Ship types specified in input \code{shipTypes} to be
#' modeled as tugs (vector of strings)
#' @param roroPaxShipTypes Ship types specified in input \code{shipTypes} to be
#' modeled as RORO and passenger ships (vector of strings)
#' @param gCargoShipTypes Ship types specified in input \code{shipTypes} to be
#' modeled as general cargo (vector of strings)
#' @param containerShipTypes Ship types specified in input \code{shipTypes} to
#' be modeled as container ships (vector of strings)
#' @param Cstern Afterbody form coefficient: \itemize{\item V-shaped Hull = -10
#'         \item U-Shaped Hull =  10
#'         \item Normal Hull = 0 (default)}
#' Can supply either a vector of numericals, a single number, or rely on the default
#' @param forwardDraft Forward draft (deviation from actual draft indicates trim)
#' (vector of numericals, m)
#' @param aftDraft Aft draft (deviation from actual draft indicates trim)
#' (vector of numericals, m)
#' @param appendagesList List of appendages on ship (vector of strings) \itemize{
#'  \item"rudder behind skeg"
#'  \item"rudder behind stern"
#'  \item"twin-screw balance rudders"
#'  \item"shaft brackets"
#'  \item"skeg"
#'  \item"strut bossings"
#'  \item"hull bossings"
#'  \item"shafts"
#'  \item"stabilizer fins"
#'  \item"dome"
#'  \item"bilge keels"}
#' @param wettedAppSAList List of wetted surface areas corresponding to list of
#' appendages (vector of numericals, m^2)
#'
#' @details
#' Primary method from Holtrop & Mennen (1982). Updated equations for high speed
#' operations (Froude number > 0.55) from Holtrop & Mennen (1984). Estimation of
#' some inputs use methodology from Rakke (2016).
#'
#' This method this requires ship types to be grouped. Use the
#' \code{tankerBulkCarrierShipTypes}, \code{tugShipTypes}, \code{roroPaxShipTypes},
#' \code{gCargoShipTypes}, \code{containerShipTypes} grouping parameters to
#' provide these ship type groupings. Any ship types not included in these groupings
#' will be considered as miscellaneous vessels.
#'
#' Ship speed and actual draft are typically obtained from sources such as AIS
#' messages or ship records.
#'
#' @return power (vector of numericals, kW)
#'
#' @references
#'Holtrop, J. and Mennen, G. G. J. 1982. "An approximate power prediction
#'method." International Shipbuilding Progress 29.
#'
#'Holtrop, J. and Mennen, G. G. J. 1984. "A Statistical Re-Analysis of Resistance
#'and Propulsion Data'.
#'
#'\href{http://hdl.handle.net/11250/2410741}{Rakke, S. G. 2016. "Ship Emissions
#'Calculation from AIS." NTNU.}
#'
#'@seealso \itemize{
#'\item \code{\link{calcSpeedUnitConversion}}
#'\item \code{\link{calclwl}}
#'\item \code{\link{calcCb}}
#'\item \code{\link{calcPropNum}}
#'\item \code{\link{calcCm}}
#'\item \code{vignette("OverviewOfPowerModels", package="ShipPowerModel")}
#'\item \code{vignette("HoltropMennen.Example", package="ShipPowerModel")}
#'}
#'
#' @family Holtrop-Mennen Calculations
#'
#' @examples
#' calcHMPwr(
#' totalInstalledPwr=rep(9363,2),,
#' shipSpeed=seq(0,1,1),
#' actualDraft=rep(12.48,2),
#' maxDraft=rep(13.57,2),
#' shipType=rep("bulk.carrier",2),
#' lwl=rep(218.75,2),
#' breadth=rep(32,2),
#' maxDisplacement=rep(80097,2),
#' Cb=rep(0.8099003,2),
#' nProp=rep(1,2),
#' serviceMargin=15,
#' shaftEff=0.98,
#' relRotationEff=1,
#' seawaterTemp=15,
#' seawaterDensity=1.025,
#' Cstern=0,
#' CmEquationType="kristensen",
#' forwardDraft=rep(13.57,2),
#' aftDraft=rep(13.57,2),
#' appendagesList=c(""),
#' wettedAppSAList=NA
#' )
#'
#' @export

  calcHMPwr<- function(
  totalInstalledPwr,
  shipSpeed,
  actualDraft,
  maxDraft,
  shipType,
  lwl,
  breadth,
  maxDisplacement,
  Cb,
  nProp,
  serviceMargin=15,
  shaftEff=0.98,
  relRotationEff=1,
  seawaterTemp=15,
  seawaterDensity=1.025,
  pwrUpperBoundPercent=1,
  pwrLowerBoundPercent=0.02,
  CmEquationType="kristensen",
  tankerBulkCarrierShipTypes=c("tanker","chemical.tanker","liquified.gas.tanker","oil.tanker","other.tanker","bulk.carrier"),
  tugShipTypes=c("service.tug","tug"),
  roroPaxShipTypes=c("passenger","ferry.pax","ferry.ro.pax","cruise","cruise.ed","yacht","ro.ro"),
  gCargoShipTypes=c("general.cargo"),
  containerShipTypes=c("container.ship"),
  Cstern=0,
  forwardDraft=NULL,
  aftDraft=NULL,
  appendagesList=c(""),
  wettedAppSAList=NA
 ){
#===========================================
if(is.null(forwardDraft)){forwardDraft<-maxDraft}
if(is.null(aftDraft)){aftDraft<-maxDraft}

#Inputs
    Cbw<-calcCbw(Cb, actualDraft, maxDraft)
    Cm<-calcCm(shipType,Cbw,maxDraft,actualDraft,CmEquationType,tankerBulkCarrierShipTypes,tugShipTypes,roroPaxShipTypes)
    Cp<-calcCp(Cm, Cbw,shipType, bounds="holtrop mennen", roroPaxContainerShipTypes=union(roroPaxShipTypes,containerShipTypes),gCargoShipTypes,tankerBulkCarrierShipTypes)
    Cwp<-calcCwp(Cbw, CwpEquationType="kristensen")
    froudeNum<-calcFroudeNum(shipSpeed, lwl)
    At<-calcAt(Cm, breadth, maxDraft)
    hb<-calchb(maxDraft)
    Abt<-calcAbt(Cm, breadth, maxDraft)
    propDiam<-calcPropDia(shipType, maxDraft,tankerBulkCarrierGCargoShipTypes=union(tankerBulkCarrierShipTypes,gCargoShipTypes),containerShipTypes)
    lcb<-calclcb(lwl)
#===========================================
Cf<-calcCf(shipSpeed,
           lwl,
           seawaterTemp,
           seawaterDensity)
#=============================================
Rapp<-calcHMAppendageRes(shipSpeed,
                          Cf,
                          appendagesList,
                          wettedAppSAList,
                          seawaterDensity)
#=============================================
Rw<-calcHMWaveMakingRes(lwl,
                         breadth,
                        Cp,
                        Cwp,
                        Cm,
                         maxDisplacement,
                         maxDraft,
                         froudeNum,
                        At,
                        hb,
                        Abt,
                         seawaterDensity,
                         forwardDraft,
                        lcb)
#========================================

FormFactor<-calcHMFormFactor(maxDraft,
                              lwl,
                              breadth,
                              maxDisplacement,
                             Cp,
                              Cstern,
                             lcb)
#==========================================

wettedSA<-calcHMWettedSA(lwl,
                          actualDraft,
                          breadth,
                          Cm,
                          Cbw,
                          Cwp,
                          Abt)
#==============================================
Rtr<-calcHMImmersedTransomRes(shipSpeed,
                               breadth,
                               Cwp,
                               maxDraft,
                             At,
                             seawaterDensity)
#==============================================
Rb<-calcHMBulbousBowRes(shipSpeed,
                         maxDraft,
                         forwardDraft,
                         Abt,
                         hb,
                         seawaterDensity)
#=============================================================
Ca<-calcHMCa(maxDraft,
                         lwl,
                         Cbw,
                         breadth,
                         forwardDraft,
                        Abt,
                         hb)
#=============================================================
w<-calcHMWakeFraction(breadth,
                      wettedSA,
                       maxDraft,
                       nProp,
                       lwl,
                      propDiam,
                      FormFactor,
                      Cf,
                      Ca,
                     Cbw,
                      Cp,
                      Cm,
                       aftDraft,
                      Cstern,
                      lcb)

t<-calcHMThrustFactor(breadth,
                       lwl,
                       maxDraft,
                       maxDisplacement,
                       nProp,
                       Cp,
                       propDiam,
                       Cbw,
                       Cstern,
                       lcb,
                       seawaterDensity)
#=============================================================

R<- calcHMTotalRes(Rapp,Rw,Rb,Rtr,seawaterDensity,wettedSA,shipSpeed,
                   Cf,FormFactor,Ca,serviceMargin)

#=============================================================
no<- calcOpenWaterEff(R,t,nProp,w,propDiam,shipSpeed)

#=============================================================
power<-calcResistanceShipPwr(R,shipSpeed, (1-t)/(1-w), no,totalInstalledPwr, shaftEff,relRotationEff, pwrUpperBoundPercent, pwrLowerBoundPercent)

 return(power)
}


subroutine dirseg(dirsgs,ndir,nadj,madj,npd,x,y,ntot,rw,eps,nerror)

# Output the endpoints of the segments of boundaries of Dirichlet
# tiles.  (Do it economically; each such segment once and only once.)
# Called by master.

implicit double precision(a-h,o-z)
logical collin, adjace, intfnd, bptab, bptcd, goferit, rwu
dimension nadj(-3:ntot,0:madj), x(-3:ntot), y(-3:ntot)
dimension dirsgs(10,ndir), rw(4)

nerror = -1

# Add in some dummy corner points, outside the actual window.
# Far enough out so that no resulting tile boundaries intersect the
# window.

# Note that these dummy corners are needed by the routine `dirout'
# but will screw things up for `delseg' and `delout'.  Therefore
# this routine (`dirseg') must be called ***before*** dirout, and
# ***after*** delseg and delout.

# Dig out the corners of the rectangular window.
xmin = rw(1)
xmax = rw(2)
ymin = rw(3)
ymax = rw(4)

a = xmax-xmin
b = ymax-ymin
c = sqrt(a*a+b*b)

npd  = ntot-4
nstt = npd+1
i = nstt
x(i) = xmin-c
y(i) = ymin-c
i = i+1
x(i) = xmax+c
y(i) = ymin-c
i = i+1
x(i) = xmax+c
y(i) = ymax+c
i = i+1
x(i) = xmin-c
y(i) = ymax+c

do j = nstt,ntot {
	call addpt(j,nadj,madj,x,y,ntot,eps,nerror)
	if(nerror > 0) return
}

# Put the segments into the array dirsgs.

# For each distinct pair of (genuine) data points, find out if they are
# adjacent.  If so, find the circumcentres of the triangles lying on each
# side of the segment joining them.
kseg = 0
do i = 2,npd {
        do j = 1,i-1 {
                call adjchk(i,j,adjace,nadj,madj,ntot,nerror)
		if(nerror > 0) return
                if(adjace) {
                        call pred(k,i,j,nadj,madj,ntot,nerror)
			if(nerror > 0) return
                        call circen(i,k,j,a,b,x,y,ntot,eps,collin,nerror)
			if(nerror > 0) return
                        if(collin) {
				nerror = 12
				return
			}
                        call succ(l,i,j,nadj,madj,ntot,nerror)
			if(nerror > 0) return
                        call circen(i,j,l,c,d,x,y,ntot,eps,collin,nerror)
			if(nerror > 0) return
                        if(collin) {
				nerror = 12
				return
			}
                        # If a circumcentre is outside the rectangular window
                        # of interest, draw a line joining it to the other
                        # circumcentre.  Find the intersection of this line with
                        # the boundary of the window; for (a,b) and call the point
                        # of intersection (ai,bi).  For (c,d), call it (ci,di).
                        # Note: rwu = "right way up".
                        xi = x(i)
                        xj = x(j)
                        yi = y(i)
                        yj = y(j)
                        if(yi!=yj) {
                            slope = (xi - xj)/(yj - yi)
                            rwu   = .true.
                        } else {
                            slope = 0.d0
                            rwu = .false.
                        }
                        call dldins(a,b,slope,rwu,ai,bi,rw,intfnd,bptab,nedgeab)
			if(!intfnd) {
				nerror = 16
				return
			}
                        call dldins(c,d,slope,rwu,ci,di,rw,intfnd,bptcd,nedgecd)
			if(!intfnd) {
				nerror = 16
				return
			}
			goferit = .false.
			if(bptab & bptcd) {
				xm = 0.5*(ai+ci)
				ym = 0.5*(bi+di)
				if(xmin<xm&xm<xmax&ymin<ym&ym<ymax) {
					goferit = .true.
				}
			}
			if((!bptab)|(!bptcd)) goferit = .true.
			if(goferit) {
				kseg = kseg + 1
				if(kseg > ndir) {
					nerror = 15
					return
				}
				dirsgs(1,kseg) = ai
				dirsgs(2,kseg) = bi
				dirsgs(3,kseg) = ci
				dirsgs(4,kseg) = di
				dirsgs(5,kseg) = i
				dirsgs(6,kseg) = j
				if(bptab) dirsgs(7,kseg) = 1.d0
				else dirsgs(7,kseg) = 0.d0
				if(bptcd) dirsgs(8,kseg) = 1.d0
				else dirsgs(8,kseg) = 0.d0
                                if(bptab) dirsgs(9,kseg) = -nedgeab
                                else dirsgs(9,kseg) = k
                                if(bptcd) dirsgs(10,kseg) = -nedgecd
                                else dirsgs(10,kseg) = l
			}
                }
        }
}
ndir = kseg

return
end


itos <- function(n) {
    unlist(strsplit(paste(n), NULL))
}

is_palindromic <- function(n) {
    v <- itos(n)
    identical(v, rev(v))
}

prods <- NULL
for (a in 100:999) {
    prods <- c(prods, a * (a:999))
}

prods <- unique(prods)
index <- sapply(prods, is_palindromic)

cat(max(prods[index]), "\n")


# Monthly averages of KNMI air pressure
# To compare with:
# https://github.com/DOV-Vlaanderen/groundwater-logger-validation/issues/61#issuecomment-708963119

round_timestamp <- function(ts, scalefactor.sec = 3600*12) {
  #as.POSIXct(round(as.numeric(ts)/scalefactor.sec) * scalefactor.sec, origin = '1970-01-01', tz = 'UTC')
  ts
}

read.baro <- function(logger.name) {
  df <- gwloggeR.data::read(logger.name)$df
  if (nrow(df) == 0L) return(df)
  df <- df[!is.na(TIMESTAMP_UTC), ]
  df <- df[!is.na(PRESSURE_VALUE), ]
  df <- df[!duplicated(TIMESTAMP_UTC), ]
  df <- df[, .('PRESSURE_VALUE' = mean(PRESSURE_VALUE)),
           by = .('TIMESTAMP_UTC' = round_timestamp(TIMESTAMP_UTC))]

  # Meta data
  df[, 'FILE' := basename(logger.name)]
  df[, 'N' := .N]

  data.table::setkey(df, TIMESTAMP_UTC)
  data.table::setattr(df, 'logger.name', logger.name)

  df
}

df <- read.baro('KNMI_20200312_hourly')
df[, YEAR_MONTH := as.POSIXct(format(TIMESTAMP_UTC, '%Y-%m-01 00:00:00'))]

df.monthly <- df[, .(PRESSURE_VALUE = mean(PRESSURE_VALUE)), by = YEAR_MONTH]
df.monthly[, MONTH := as.integer(data.table::month(YEAR_MONTH))]
df.monthly

ggplot2::ggplot(data = df.monthly, mapping = ggplot2::aes(x = MONTH, y = PRESSURE_VALUE)) +
  ggplot2::geom_point() +
  ggplot2::geom_smooth() +
  ggplot2::ggtitle('KNMI data: monthly averaged observations') +
  ggplot2::scale_x_continuous(breaks = 1:12)
  ggplot2::theme_light()

ggplot2::ggsave('./drifts/analysis_31/knmi_monthly_averages.png', width = 1280/96, height = 720/96, dpi = 96)


#********************************************************************************
#                          INSTALL PACKAGES SECTION
#********************************************************************************

install.packages("RcmdrMisc")
install.packages("tidyverse")
install.packages("ForImp")
install.packages("psych")
install.packages("pastecs")

#********************************************************************************
#                          SETTING WORKING DIRECTORY
#********************************************************************************

getwd()
setwd("C:/Users/DECA/Desktop/Learning/")

#********************************************************************************
#                          IMPORT LIBRARIES
#********************************************************************************

library(readxl)
library("ggpubr")
library(RcmdrMisc)
library(haven)
library(ForImp)
library(car)
library(psych)
library(pastecs)

# OBTAINING DATA
BD1 <- read_excel("BD1 Test.xlsx", sheet = "Sheet1")
summary(BD1)

#T TEST OF V2 AND V4A_D & V4B_D
t.test(V2~ Va_d,
       alternative="two.sided",
       conf.level=.95,
       var.equal = TRUE,
       data = BD1)

t.test(V2~ Vb_d,
       alternative="two.sided",
       conf.level=.95,
       var.equal = TRUE,
       data = BD1)

#CORRELATION MATRIX
rcorr.adjust(
  BD1[c("V2d","Va_d","Vb_d")],
  type="pearson",
  use="complete")

#IMPLEMENTING DATA TREATMENT
BD1T<-ld(within(BD1,{V4b <- NULL}))
show(BD1T)
BD1T<-ld(within(BD1,{V4b <- NULL}))
numSummary(BD1T[c("C1","V1","V2","V3","V4a","V5")],statistics = c("mean","sd"))

#REMOVE DATA BASED ON A SINGLE COLUMN VALUE
BD2T<-subset(BD1, !is.na(V2), data=BD1)
numSummary(BD2T[c("V4a","V1","V2","V3","V5","C1")],statistics = c("mean","sd"))
BD2T<-subset(BD1, !is.na(V4a), data=BD1)
numSummary(BD2T[c("V4a","V1","V2","V3","V5","C1")],statistics = c("mean","sd"))
numSummary(BD1[c("V4a","V1","V2","V3","V5","C1")],statistics = c("mean","sd"))

#REGRESSION IMPUTATION
BD1R<-lm(V4a~V1+V3+V5+C1, data=BD1)
summary(BD1R)
colnames(summary(BD1R)$coef)
V1<-summary(BD1R)$coef[,"Estimate"]["V1"]
V3<-summary(BD1R)$coef[,"Estimate"]["V3"]
V5<-summary(BD1R)$coef[,"Estimate"]["V5"]
C1<-summary(BD1R)$coef[,"Estimate"]["C1"]
Intercept<-summary(BD1R)$coef[,"Estimate"]["(Intercept)"]
BD1I<-BD1
for (x in 1:dim(BD1)[1]) {
  if (is.na(BD1$V4a[x])) {
    BD1I$V4a[x]<-Intercept+V1*BD1$V1[x]+V3*BD1$V3[x]+V5*BD1$V5[x]+C1*BD1$C1[x]
    print(BD1I$V4a[x])
  }
}
#CRITICAL VALUE OF A T DISTRIBUTION
qt((0.05/200),98,lower.tail = F)

#MULTI VARIABLE ATIPICAL DATA DETECTION
X<-matrix(c(13,5031,130,1168,12,
            16,5735,165,1231,12,
            13,5211,150,1145,11,
            15,4982,150,1144,12,
            14,4949,140,1149,11,
            16,7030,198,1447,10,
            17,7440,220,1451,9,
            17,7210,215,1437,9,
            17,7456,225,1475,10,
            16,6391,190,1283,9),nrow = 10,ncol = 5, byrow = T)

mean<-colMeans(X)
Sx<-cov(X)
D2<-mahalanobis(X,mean,Sx,inverted = FALSE)
#FIND CRITICAL MAHALANOBIS VALUE
#1. DF = # of Variables (Significativity)
pchisq(D2, df=5, lower.tail=FALSE)
#2. Find Critical Value with
qchisq(.99, df=5)

#NORMAL
round(stat.desc(X, basic = F, norm = T),
      digits=3)


#!/usr/bin/Rscript
# Output max value for numerator and denominator in future division
# This runs on Data Owners' side, since it needs access to raw data

# to customize: input data
datadir <- "data/raw_data_sorted.csv"
mydata <- read.csv(datadir, sep=",", head=TRUE)

# s.e. is in column 12
# beta is in column 11
weight_i <- (1 / mydata[, 12])^2
beta_weight <- mydata[, 11] * weight_i

# max of numerator (without square)
print( max(weight_i) )
# max of denominator
print( max(beta_weight) )


#' Minhash Document Shingles
#'
#' @param shingles list of shingled documents (from \code{shingle_*()} functions)
#' @param n number of minhashes per document
#' @param seed optional seed used when generating minhash functions
minhash <- function(shingles, n = 100, seed = NULL) {
  # generate minhasher
  f <- minhash_generator(n, seed)

  # generate minhash for every shingle
  vals <- pbmcapply::pbmclapply(shingles, f)

  # build minhash matrix
  matrix(unlist(vals), nrow = n)
}

#' Generate n random integers
#'
#' Used to parametrize the minhasher
#' @param n number of integers
#' @param seed optional seed
random_ints <- function(n, seed = NULL) {
  if (!is.null(seed)) set.seed(seed)
  sample.int(.Machine$integer.max, size = n)
}

#' Generate a minhash function
#'
#' @param n number of minhashes per document
#' @param seed optional seed used when generating minhash functions
minhash_generator <- function(n, seed = NULL) {
  rs <- random_ints(n, seed)

  # return generator function
  # x is a shingled document
  function(x) {
    # get minhash for every hash function (paramaterized by a random int from rs)
    vapply(rs, function(r) min(bitwXor(x, r)), integer(1L), USE.NAMES = FALSE)
  }
}

#' jaccard similarity on minhashes
jaccard_minhashes <- function(x, y) {
  mean(x == y)
}


#Select matching expression pattern
ecdf_fun <- function(x, perc){
  return(ecdf(x)(perc))
}

PreprocessExpression <- function(ExpressionData){
  all_quant <- c()
  for (i in names(ExpressionData)) {
    all_quant <-
      c(all_quant, seq(5, 95, 10)[data.table::between(
        x = ecdf_fun(ExpressionData, ExpressionData[i]),
        lower = seq(0, 0.9, 0.1),
        upper = seq(0.1, 1, 0.1)
      )])
  }
  names(all_quant) <- names(ExpressionData)
  return(all_quant)
}

SelectMatchingExpression <-
  function(TargetGenes, ExpressionData, Nrand, QuantizedGenes) {
    if (missing(QuantizedGenes)){
      all_quant <- PreprocessExpression(ExpressionData)
    } else{
      all_quant <- QuantizedGenes
    }
    expr_quant <- all_quant[names(all_quant) %in% TargetGenes]
    expr_quant_dist <- table(expr_quant)
    rnd_match_genes <- vector("list", Nrand)
    for (i in 1:Nrand){
      for (j in 1:length(expr_quant_dist)){
        rnd_match_genes[[i]] <- c(rnd_match_genes[[i]],
          sample(names(all_quant[all_quant == names(expr_quant_dist)[j]]),
                  size = expr_quant_dist[j]))
      }
    }
    return(rnd_match_genes)
  }

SelectMatchingExpressionParallel <-
  function(TargetGenes, ExpressionData, Nrand, QuantizedGenes) {
    if (missing(QuantizedGenes)){
      all_quant <- PreprocessExpression(ExpressionData)
    } else{
      all_quant <- QuantizedGenes
    }
    expr_quant <- all_quant[names(all_quant) %in% TargetGenes]
    expr_quant_dist <- table(expr_quant)
    rnd_match_genes <- vector("list", Nrand)
    rnd_match_genes <- mclapply(c(1:Nrand),
                                FUN = function(x){
                                  tmp.c <- c()
                                  for (j in 1:length(expr_quant_dist)){
                                    tmp.c <-
                                      c(tmp.c,
                                        sample(names(all_quant[all_quant ==
                                                                 names(expr_quant_dist)[j]]),
                                               size = expr_quant_dist[j]))
                                  }
                                  return(tmp.c)
                                }, mc.cleanup = TRUE, mc.cores = 32)

    return(rnd_match_genes)
  }

ParallelRandomGeneSetGenerate <-
  function(tested_datasets, ExpressionDataInput,
           Nrandom = 100, PreprocessedExprData){
    rnd.data <- vector("list", length(tested_datasets))
    for (i in 1:length(tested_datasets)){
      rnd.data[[i]] <- vector("list", length(ExpressionDataInput))
      message(Sys.time(),
              " processing ",
              i," out of ",
              length(tested_datasets))
      rnd.data[[i]] <-
        mcmapply(FUN = SelectMatchingExpression,
                 ExpressionData = ExpressionDataInput,
                 TargetGenes = tested_datasets[[i]],
                 Nrand = Nrandom,
                 QuantizedGenes = PreprocessedExprData
        )
    }
    return(rnd.data)
  }

ParallelEstimateConnectivityP <-
  function(ModuleEdges, Network, Module, RndData, Degrees){
    rnd.conn.est <-
      (length(E(subNetwork(unique(c(V(Module)$name,
                                 RndData)), Network))) -
      ModuleEdges -
       length(E(subNetwork(RndData, Network)))) /
      sum(Degrees[names(Degrees) %in% RndData], na.rm = TRUE)
    return(rnd.conn.est)
  }


offsetof(record_t, c) = 0
offsetof(record_t, x) = 4
offsetof(record_t, y) = 8
Addition of offsets (c+x+y)= 12
Subtraction of offsets (y-x)= 4
Multiplication of offsets (x*c) = 0
Division of offsets (y/x) = 2


library(ggplot2)
data(iris)

shinyServer(function(input, output) {

output$plot <- renderPlot({
	if(!input$color) {
	ggplot(iris, aes_string(input$x, input$y)) + geom_point(size =3)
	} else {
		ggplot(iris, aes_string(input$x, input$y)) +
		geom_point(aes(color = Species), size = input$size)
	}
	})

})


#!/usr/bin/env Rscript
#
# Fisher Exact Test p-values from 2x2 contingency table
#
args <- commandArgs(TRUE)
infile = paste("", args[1], sep="")
outfile = paste("", args[2], sep="")
if(nchar(infile) >= 1 && !infile == "NA" && nchar(outfile) >= 1 && !outfile == "NA") {
    x = read.table(infile, sep="\t", header=F)
    dx = data.matrix(x)
    n = dim(dx)[1]
    if(n >= 1) {
        p = rep(1, n)
        for(i in 1:n) {d=matrix(dx[i,],nrow=2); p[i]=fisher.test(d, alternative = "greater",conf.int=F)$p}
        fdr = p.adjust(p)
        dxp = data.frame(dx,p,fdr)
        names(dxp) = c("a","b","c","d","p-value","fdr")
        if(nchar(outfile) >= 1) {
            write.table(dxp, outfile, quote=F, sep="\t", row.names=F, col.names=T)
        } else {
            print(dxp)
        }
    }
} else {
    warning("Usage: fisher-pvals.r [input table (a,b,c,d)] [output table (a,b,c,d,p-value,fdr)]")
}


# try this

trimean <-  function(vect)  { foo <- fivenum(vect); ans <- 0.5*foo[3] + 0.25*foo[2] + 0.25*foo[4]; ans }
midmean <-  function(vect)  { ans <- mean(vect,trim=0.25,na.rm=TRUE); ans }

foo<-dat
bar<-data.frame(foo$copies,foo$lifem,foo$lost,
                foo$shockfreq,foo$shockimpact,
                foo$shockspan,foo$shockmaxlife)
d0<-bar
datsumm<-data.frame(rbind(numeric(6)))
colnames(datsumm)<-c("span","lifem","cop2","cop3","cop4","cop5")

c1<-d0$foo.shockspan
f1<-levels(factor(c1))
for (s1 in f1) {d1<-data.frame(d0[c1==s1,])

  c2<-d1$foo.lifem
  f2<-levels(factor(c2))
  for (s2 in f2) {d2<-data.frame(d1[c2==s2,])

      tmp11 <- aggregate(d2, by=list(d2$foo.copies),
        FUN=midmean)
      newrow<-c(s1,s2,round(tmp11$foo.lost,1))
      #print(newrow)
      datsumm <- rbind(datsumm,as.numeric(newrow))
  }
}

datsumm<-datsumm[-1,]
print(datsumm)
while (sink.number() > 0) {sink()}

if(1){
# now do it in the other order.
datsummrev<-data.frame(rbind(numeric(6)))
colnames(datsummrev)<-c("lifem","span","cop2","cop3","cop4","cop5")

c1<-d0$foo.lifem
f1<-levels(factor(c1))
for (s1 in f1) {d1<-data.frame(d0[c1==s1,])

  c2<-d1$foo.shockspan
  f2<-levels(factor(c2))
  for (s2 in f2) {d2<-data.frame(d1[c2==s2,])

    tmp11 <- aggregate(d2, by=list(d2$foo.copies),
      FUN=midmean)
    newrowrev<-c(s1,s2,round(tmp11$foo.lost,1))
    #print(newrowrev)
    datsummrev <- rbind(datsummrev,as.numeric(newrowrev))
  }
}

datsummrev<-datsummrev[-1,]
print(datsummrev)
while (sink.number() > 0) {sink()}
}#ENDIFFALSE

sink("tmp.txt")
print(datsumm)
print(datsummrev)
sink()

while (sink.number() > 0) {sink()}

#conclusion 20170321.1345: nope, the aggregation is being done on
#some other planet.  closer examination required.  the shape is right,
#though.
#conclusion 20170321.1620: almost seems to work!  bronze it and try more!


rm(list=ls())
s <- "./mfSBA K1_laSelva.sed q.sed 2 512 20 S"

system(s)

sf <- read.table("s.K1_laSelva.sed", header=T)

readDq <- function(sname) {

  pp <- read.table(sname, header=T)

  pp$Dq  <- with(pp,ifelse(q==1,alfa,Tau/(q-1)))

  pp$SD.Dq  <- with(pp,ifelse(q==1,SD.alfa,abs(SD.Tau/(q-1))))

  pp$R.Dq <- with(pp,ifelse(q==1,R.alfa,R.Tau))

  return(pp[,c("q","Tau","SD.Tau","Dq","SD.Dq","R.Dq")])
}

s <- "./mfSBA K2_MaunaKea.sed q.sed 2 512 20 S"

system(s)

sf <- readDq("s.K1_laSelva.sed")
sf1 <- readDq("s.K2_MaunaKea.sed")

require(ggplot2)

pp <- ggplot(sf, aes(x=R.Dq)) + geom_histogram()

pp

range(sf$R.Dq)

range(sf$Dq)

pp <- ggplot(sf, aes(x=q, y=Dq)) + ylim(1.9,2.09) +
  geom_errorbar(aes(ymin=Dq-2*SD.Dq, ymax=Dq+2*SD.Dq), width=.1)+
  geom_line() +
  geom_point()

pp

sf$plot <- "LaSelva"

sf1$plot <- "MaunaKea"

sft <- rbind(sf,sf1)

#

pp <- ggplot(sft, aes(x=q, y=Dq, color=plot)) +
  geom_errorbar(aes(ymin=Dq-2*SD.Dq, ymax=Dq+2*SD.Dq), width=.1)+
  geom_line() +
  geom_point()
pp

# Execute mfSBA
# Plot histogram
# add to data.frame dq
addDqRHist <- function(fname,dq=0,siten="")
{
  # Make multifractal analysis
  sname <- paste0("s.",fname)
  if(!file.exists(sname) )
  {
    s <- paste("./mfSBA",fname, "q.sed 2 512 20 S")
    system(s)
  }

  # Extract site label
  if( nchar(siten)==0 ){
    siten <- strsplit(fname,"_")[[1]][2]
    siten <- strsplit(siten,".sed")[[1]][1]
  }
  sname <- paste0("s.",fname)
  dqnew <- readDq(sname)
  dqnew$Site <- siten

  require(ggplot2)

  print(ggplot(dqnew, aes(x=R.Dq)) + geom_histogram() + ggtitle(siten))

  if(is.data.frame(dq))
    return(rbind(dq,dqnew))
  else
    return(dqnew)
}

rm(pp)
pp <- addDqRHist("K1_laSelva.sed")
pp <- addDqRHist("K2_MaunaKea.sed",pp)
pp <- addDqRHist("K3_Laupahoehoe.sed",pp)
pp <- addDqRHist("K4_Montane.sed",pp)
pp <- addDqRHist("K5_Kohala.sed",pp)

gp <- ggplot(pp, aes(x=q, y=Dq, color=Site)) +
  geom_errorbar(aes(ymin=Dq-SD.Dq, ymax=Dq+SD.Dq), width=.1) +
  geom_line() +
  geom_point()

gp


hamming <- function(n) {
  a <- numeric(n)
  a[1] <- 1
  for (i in 2:n) {
    a[i] <- nextn(a[i-1]+1)
  }
  a
}


Also:

xmas=seq(as.Date("2008/12/25"), as.Date("2121/12/25"), by="year")
as.numeric(format(xmas[weekdays(xmas)== 'Sunday'], "%Y"))


options(scipen=999)
args = commandArgs(trailingOnly=TRUE)

true_genotypes = as.matrix(read.table("trueGenotypes.txt"))
idList = read.table("offspring.txt")[,1]

true_offspring = true_genotypes[true_genotypes[,1] %in% idList,]
true_parents = true_genotypes[ ! true_genotypes[,1] %in% idList,]

getAccuracyFast = function(prefix){
    out = tryCatch({
        fileName = paste0(prefix, ".dosages")

        imputed = as.matrix(read.table(fileName))
        imputed_offspring = imputed[imputed[,1] %in% idList,]
        imputed_parents = imputed[!imputed[,1] %in% idList,]

        offspring_values = getAccuracy(true_offspring, imputed_offspring)
        parent_values = getAccuracy(true_parents, imputed_parents)

        values = data.frame(algorithm = prefix, generation = c("0", "1"), indAcc = c(parent_values[1], offspring_values[1]), markerAcc = c(parent_values[2], offspring_values[2]))
        return(values)
    },
    error=function(cond){
        return(NULL)
    })
}

getAccuracy = function(target, mat){

    indAcc = sapply(1:nrow(mat), function(i) {
        return(cor(mat[i, -1], target[i, -1]))
    })
    markerAcc = sapply(2:ncol(mat), function(i) {
            return(cor(mat[, i], target[, i]))
    })

    return(c(mean(indAcc), mean(markerAcc, na.rm=T)))
}
# getAccuracyFast("em")

values = list(  getAccuracyFast("outputs/magic") )
values = do.call("rbind", values)
print(values)

prefix = "outputs/magic"
fileName = paste0(prefix, ".dosages")

imputed = as.matrix(read.table(fileName))
imputed_offspring = imputed[imputed[,1] %in% idList,]
imputed_parents = imputed[!imputed[,1] %in% idList,]

indAcc = sapply(1:nrow(imputed_offspring), function(i) {
    return(cor(imputed_offspring[i, -1], true_offspring[i, -1]))
})
markerAcc = sapply(2:ncol(imputed_offspring), function(i) {
        return(cor(imputed_offspring[, i], true_offspring[, i]))
})

plot(indAcc)
plot(markerAcc)


### blup estimates for phenotypic traits across multiple envionments##
### Broad-sense heritability estimation across multiple envionments
### THE DATA SHOULD INCLUDE THREE COLUMNS AT LEAST,DENOTED AS 'LINE','LOC' AND 'TRAIT1...TRAITn'

Onewaybluph2NEW<-function(x){
##Calculate variance components
##require package lme4
library(Matrix)
library(lme4)
id<-as.character(x$LINE[x$LOC%in%unique(x$LOC)[1]])
line.blup<-list()
heritability<-list()

for(i in 3:ncol(x)){
		cat(names(x)[i],'start\n')
		varcomp<-lmer(x[,i]~(1|LINE)+(1|LOC),data=x)
		vc = data.frame(VarCorr(varcomp))
		var = vc[match(c('LINE','LOC','Residual'),vc$grp),c('grp','vcov')]
		names(var)=c('Groups','Variance')
		gvar<-as.numeric(as.character(var$Variance))[var$Groups%in%'LINE']
		evar<-as.numeric(as.character(var$Variance))[var$Groups%in%'Residual']
		heritability[[i-2]]<-matrix(gvar/(gvar+evar/length(unique(x$LOC))),1,1,dimnames=list(colnames(x)[i],'H2'))
		f<-fixef(varcomp)
		r<-ranef(varcomp)$LINE
		blup<-round(f+r,4)
		line.blup[[i-2]]<-blup[match(id,rownames(blup)),]
	}
	heritability=do.call('rbind',heritability)
	line.blup=data.frame(id,do.call('cbind',line.blup))
	colnames(line.blup)<-c('line',names(x)[-c(1:2)])

	cat('----OUTPUT RESULTS OF EACH TRAITS INTO FILES:----','\n','----BroadSenseHeritability.txt----','\n',
 '----BlupEachlines.txt----','\n')

	write.table(heritability,'RGB-CK_BroadSenseHeritability.txt',sep='\t',quote=F)
	write.csv(line.blup,'RGB-CK_BlupEachlines.csv',row.names=F)
}

x<-read.table("RGB-CK.txt",header=T,sep="\t")

Onewaybluph2NEW(x)


context("compare clustered results to Stata")

test_that("sampsi 12 16, alpha(.05) power(.8) sd(5)
           sampclus, obsclus(10) rho(0.3)", {
	calc <- twomeans(m1 = 12, m2 = 16, sd = 5) %>% clustered(obsclus = 10, rho = 0.3)
	expect_equal(calc$`Average per cluster`, 10)
    expect_equal(calc$`Mininum number of clusters`, 19)
    expect_equal(calc$`n2 (adjusted)`, 93)
    expect_equal(calc$`n2 (adjusted)`, 93)
})


set.seed(1919)
library(dplyr)
library(randomForest)
library(caret)
library(mlbench)
library(ROCR)

raw_dat <- read.table("~/SCnorm_Combat_Exp_Matrix.txt", header = T, row.names = 1, sep = "\t", stringsAsFactors = F)
raw_dat[,1:ncol(raw_dat)] <- lapply(raw_dat[,1:ncol(raw_dat)], as.numeric)
raw_dat<- scale(raw_dat)
raw_dat <- as.data.frame(t(raw_dat))
raw_dat$names <- rownames(raw_dat)
raw_dat <- arrange(raw_dat, names)
rownames(raw_dat) <- raw_dat$names
raw_dat <- raw_dat[,-ncol(raw_dat)]

sample_dat <- read.table("~/scirep_classes.txt", header = T, sep = ",", stringsAsFactors = F)
sample_class <- as.factor(arrange(sample_dat, sample_id)$label)

subsets = c(1:10, 20, 30, 40, 50)
ctrl= rfeControl(functions = rfFuncs, method = "cv",verbose = FALSE, returnResamp = "final")
Profile = rfe(raw_dat, sample_class, sizes = subsets, rfeControl = ctrl)

Profile

rfe_dat <- raw_dat[,Profile$optVariables]

n_samples <- nrow(rfe_dat)
n_train <- floor(n_samples * 0.8)
indices <- sample(1:n_samples)
indices <- indices[1:n_train]
train_sample <- rfe_dat[indices,]
train_sample_class <- sample_class[indices]
test_sample <- rfe_dat[-indices,]
test_sample_class <- sample_class[-indices]

test_sample_class

for(i in 1:8){
    rf_classifier = randomForest(x = train_sample, y = train_sample_class,  ntree = 400, mtry = i)
    print(mean(rf_classifier$err.rate))
}

rf_classifier = randomForest(x = train_sample, y = train_sample_class,  ntree = 400, mtry = 6)
rf_classifier

predicted_classes <- predict(rf_classifier, test_sample)

predicted_probs <- predict(rf_classifier, test_sample, type = 'prob')

# 定义versicolor为正类别
positive_class <- 'Healthy Control'

test_labels <- vector('integer', length(test_sample_class))
test_labels[test_sample_class != positive_class] <- 0
test_labels[test_sample_class == positive_class] <- 1
# 通过prediction函数，使用预测为正样本的概率和真实类别创建一个对象pred
pred <- prediction(predicted_probs[, positive_class], test_labels)

roc <- performance(pred, 'tpr', 'fpr')
plot(roc, main = 'ROC Curve')
auc <- performance(pred, 'auc')
cat('auc =', auc@y.values[[1]], '\n')


dyn.load("tlpreg")

# multiple regression
library(foreach)

fit.mtlpreg1 <- function(Y, X, b.init = NULL, pen.fac = rep(1,ncol(X)),
                      tau=0.5*sqrt(log(p)/n), K=NULL, nfold=10, tol=1e-4, dc.maxit=as.integer(max(5,1+log2(n/log(p)))), cd.maxit=1e+4) {
    n <- nrow(X)
    p <- ncol(X)
    if (n < nfold) stop("nfold cannot be larger than n.")

    if(is.null(K))
        K <- 1:min(p, as.integer(0.5*n/log(p)))
    nK <- as.integer(length(K))

    obs.fold <- rep(1:nfold,n)[sample.int(n)]
    foreach(k = 1:ncol(Y)) %do% {

        cv <- foreach(fold = 1:nfold, .combine = "cbind") %do% {
            b <- tlpreg1(y=Y[obs.fold!=fold,k], X=X[obs.fold!=fold,], b.init=NULL,
                         tau=tau, K=K, pen.fac=pen.fac,
                         tol=tol, dc.maxit=dc.maxit, cd.maxit=cd.maxit)$b
            apply(b, 2, function(beta) {
                res <- (Y[obs.fold==fold,k] - X[obs.fold==fold,] %*% beta)
                mean((res - mean(res))^2)
            })
        }

        tlpreg1(y=Y[,k], X=X, b.init = b.init, pen.fac = pen.fac,
                      tau=tau, K=K[which.min(rowMeans(cv))], tol=tol, dc.maxit=dc.maxit, cd.maxit=cd.maxit)
    }

}


# Analysis of acute and post acute outcomes

# first load libraries
library(lme4)
library(lmerTest)

# get data
pacutes = read.csv("[PATH TO FILE]/pacutes_314.csv")

# The code below reproduces the last 2 columns of Table2 in the man manuscript
# The first model is without, the second is with the guess component
m1  = lmer(formula = value ~ (1|trial_id) + condition + expectation + psychiatric_past , data=subset(pacutes, test_name=='PANAS'))
m2  = lmer(formula = value ~ (1|trial_id) + condition + expectation + psychiatric_past + guess, data=subset(pacutes, test_name=='PANAS'))

# Next obtain the summary stats from both model: these are the numbers in the table; estimate+-1.96*std error
summary(m1)
summary(m2)

# Repeat the same for all acute / post-acute outcomes
m1  = lmer(formula = value ~ (1|trial_id) + condition + expectation + psychiatric_past , data=subset(pacutes, test_name=='positive'))
m2  = lmer(formula = value ~ (1|trial_id) + condition + expectation + psychiatric_past + guess, data=subset(pacutes, test_name=='positive'))

m1  = lmer(formula = value ~ (1|trial_id) + condition + expectation + psychiatric_past , data=subset(pacutes, test_name=='negative'))
m2  = lmer(formula = value ~ (1|trial_id) + condition + expectation + psychiatric_past + guess, data=subset(pacutes, test_name=='negative'))

m1  = lmer(formula = value ~ (1|trial_id) + condition + expectation, data=subset(pacutes, test_name=='intensity'))
m2  = lmer(formula = value ~ (1|trial_id) + condition + expectation + guess, data=subset(pacutes, test_name=='intensity'))

m1  = lmer(formula = value ~ (1|trial_id) + condition + expectation + psychiatric_past + c(sex), data=subset(pacutes, test_name=='energy'))
m2  = lmer(formula = value ~ (1|trial_id) + condition + expectation + psychiatric_past + c(sex) + guess, data=subset(pacutes, test_name=='energy'))

m1  = lmer(formula = value ~ (1|trial_id) + condition + expectation + psychiatric_past, data=subset(pacutes, test_name=='mood'))
m2  = lmer(formula = value ~ (1|trial_id) + condition + expectation + psychiatric_past + guess, data=subset(pacutes, test_name=='mood'))

m1  = lmer(formula = value ~ (1|trial_id) + condition + expectation + psychiatric_past, data=subset(pacutes, test_name=='creativity'))
m2  = lmer(formula = value ~ (1|trial_id) + condition + expectation + psychiatric_past + guess, data=subset(pacutes, test_name=='creativity'))

m1  = lmer(formula = value ~ (1|trial_id) + condition + expectation + psychiatric_past, data=subset(pacutes, test_name=='focus'))
m2  = lmer(formula = value ~ (1|trial_id) + condition + expectation + psychiatric_past + guess, data=subset(pacutes, test_name=='focus'))

m1  = lmer(formula = value ~ (1|trial_id) + condition + expectation + psychiatric_past, data=subset(pacutes, test_name=='temper'))
m2  = lmer(formula = value ~ (1|trial_id) + condition + expectation + psychiatric_past + guess, data=subset(pacutes, test_name=='temper'))

m1  = lmer(formula = value ~ (1|trial_id) + age + condition + c(sex), data=subset(pacutes, test_name=='CPS'))
m2  = lmer(formula = value ~ (1|trial_id) + age + condition + c(sex) + guess, data=subset(pacutes, test_name=='CPS'))

m1  = lmer(formula = value ~ (1|trial_id) + age + condition, data=subset(pacutes, test_name=='ooo'))
m2  = lmer(formula = value ~ (1|trial_id) + age + condition + guess, data=subset(pacutes, test_name=='ooo'))

m1  = lmer(formula = value ~ (1|trial_id) + age + condition, data=subset(pacutes, test_name=='rotations'))
m2  = lmer(formula = value ~ (1|trial_id) + age + condition + guess , data=subset(pacutes, test_name=='rotations'))

m1  = lmer(formula = value ~ (1|trial_id) + age + condition, data=subset(pacutes, test_name=='spatial_planning'))
m2  = lmer(formula = value ~ (1|trial_id) + age + condition + guess , data=subset(pacutes, test_name=='spatial_planning'))

m1  = lmer(formula = value ~ (1|trial_id) + age + condition, data=subset(pacutes, test_name=='spatial_span'))
m2  = lmer(formula = value ~ (1|trial_id) + age + condition + guess , data=subset(pacutes, test_name=='spatial_span'))

m1  = lmer(formula = value ~ (1|trial_id) + age + condition, data=subset(pacutes, test_name=='feature_match'))
m2  = lmer(formula = value ~ (1|trial_id) + age + condition + guess , data=subset(pacutes, test_name=='feature_match'))

m1  = lmer(formula = value ~ (1|trial_id) + age + condition, data=subset(pacutes, test_name=='paired_associates'))
m2  = lmer(formula = value ~ (1|trial_id) + age + condition + guess , data=subset(pacutes, test_name=='paired_associates'))

# Post-acute outcomes
m1  = lmer(formula = value ~ (1|trial_id) + condition + expectation + psychiatric_past, data=subset(pacutes, test_name=='WEMWB'))
m2  = lmer(formula = value ~ (1|trial_id) + condition + expectation + psychiatric_past + guess, data=subset(pacutes, test_name=='WEMWB'))

m1  = lmer(formula = value ~ (1|trial_id) + condition + psychiatric_past + sss, data=subset(pacutes, test_name=='QIDS'))
m2  = lmer(formula = value ~ (1|trial_id) + condition + psychiatric_past + sss + guess, data=subset(pacutes, test_name=='QIDS'))

m1  = lmer(formula = value ~ (1|trial_id) + condition + psychiatric_past + sss, data=subset(pacutes, test_name=='STAIT'))
m2  = lmer(formula = value ~ (1|trial_id) + condition + psychiatric_past + sss + guess, data=subset(pacutes, test_name=='STAIT'))

m1  = lmer(formula = value ~ (1|trial_id) + condition + psychiatric_past, data=subset(pacutes, test_name=='SCS'))
m2  = lmer(formula = value ~ (1|trial_id) + condition + psychiatric_past + guess, data=subset(pacutes, test_name=='SCS'))


  # ---------------------------------------------------------------------
  # predict weights of individuals that do not have weights recorded from groundfish surveys
  # (for the moment, obtain weight-cw relationship from groundfish surveys and apply to cw from
  # snowcrab surveys
  # ------------------------------------------------------------------

  predictweights = function( Y, parameterisation="bio") {

    # sex codes
    male = 0
    female = 1
    sex.unknown = 2

    # maturity codes
    immature = 0
    mature = 1
    mat.unknown = 2

    # fill in missing weights from historical data as they used regression to do this ..
    # a slight variation is that the model chosen in 2007 includes shell condition as well

    if (parameterisation=="bio") {
      # develop regression relationships for each of: using cw, sex, maturity, shell, weighted by sa

      x = Y

      x$log.mass = log(x$mass)
      x$log.cw = log(x$cw)
      x$log.chela = log(x$chela)
      x$log.abdom =log(x$abdomen)
      x0 = x
      ii = which( x$sex%in% c(male, female) )
      x$sex = factor(x$sex, levels=c(male,female) )

      mod = glm( log.mass ~ log.cw + log.cw:sex, weights=sa, data=x, na.action='na.exclude')
      x$predictedmass = predict( mod, x )
      x$rstand =  abs( x$log.mass - x$predictedmass )
      x$rstand =   x$rstand  / sqrt(var(x$rstand, na.rm=T))

      jj = which(x$rstand  > 3 )
      x$log.mass [ jj ] = x$predictedmass [ jj ]
      kk = which( !is.finite( x$log.mass ) )
      x$log.mass [ kk ] = x$predictedmass [ kk ]

      # still a few NA's: fill in with a simpler model dependent only upon cw ~ 500 cases
      mod = glm( log.mass ~ log.chela, weights=sa, data=x, na.action='na.exclude')
      x$predictedmass = predict( mod, x )
      kk = which( !is.finite( x$log.mass ) )
      x$log.mass [ kk ] = x$predictedmass [ kk ]

      # still a few NA's: fill in with a simpler model dependent only upon cw ~ 500 cases
      mod = glm( log.mass ~ log.abdom, weights=sa, data=x, na.action='na.exclude' )
      x$predictedmass = predict( mod, x )
      kk = which( !is.finite( x$log.mass ) )
      x$log.mass [ kk ] = x$predictedmass [ kk ]

      Y$mass = exp(x$log.mass)

      return(Y)

# summary(mod);Anova(mod) from 2007 data

#Call:
#lm(formula = mass ~ cw + cw:sex + shell, subset = ii, weights = sa,
#    na.action = "na.exclude")

#Residuals:
#      Min        1Q    Median        3Q       Max
#-0.174287 -0.003357 -0.000181  0.003389  0.141542

#Coefficients:
#             Estimate Std. Error t value Pr(>|t|)
#(Intercept) -7.464833   0.024413 -305.78  < 2e-16 ***
#cw           2.890774   0.003796  761.55  < 2e-16 ***
#shell2       0.053130   0.017581    3.02   0.0025 **
#shell3       0.125508   0.017627    7.12  1.1e-12 ***
#shell4       0.154578   0.018308    8.44  < 2e-16 ***
#shell5       0.164819   0.039400    4.18  2.9e-05 ***
#cw:sex2     -0.023230   0.000649  -35.81  < 2e-16 ***
#---

#Residual standard error: 0.00838 on 13236 degrees of freedom
#  (36127 observations deleted due to missingness)
#Multiple R-Squared: 0.985,	Adjusted R-squared: 0.985
#F-statistic: 1.46e+05 on 6 and 13236 DF,  p-value: <2e-16

#Anova Table (Type II tests)

#Response: mass
#          Sum Sq    Df  F value Pr(>F)
#cw         49.76     1 708761.9 <2e-16 ***
#shell       0.05     4    186.7 <2e-16 ***
#cw:sex      0.09     1   1282.6 <2e-16 ***
#Residuals   0.93 13236
#---
#Signif. codes:  0 ‘***’ 0.001 ‘**’ 0.01 ‘*’ 0.05 ‘.’ 0.1 ‘ ’ 1

#> summary(mod);Anova(mod)

#Call:
#lm(formula = mass ~ cw + cw:sex, data = newdata, weights = sa,     na.action = "na.exclude")

#Residuals:
#       Min         1Q     Median         3Q        Max
#-0.0840392 -0.0021296 -0.0000281  0.0019451  0.1309121

#Coefficients:
#              Estimate Std. Error t value Pr(>|t|)
#(Intercept) -7.7028530  0.0014793   -5207   <2e-16 ***
#cw           2.9630510  0.0003513    8435   <2e-16 ***
#cw:sex2     -0.0150139  0.0000779    -193   <2e-16 ***
#---
#Signif. codes:  0 ‘***’ 0.001 ‘**’ 0.01 ‘*’ 0.05 ‘.’ 0.1 ‘ ’ 1

#Residual standard error: 0.00379 on 205565 degrees of freedom
#  (1109 observations deleted due to missingness)
#Multiple R-Squared: 0.997,	Adjusted R-squared: 0.997
#F-statistic: 3.96e+07 on 2 and 205565 DF,  p-value: <2e-16

#Anova Table (Type II tests)

#Response: mass
#          Sum Sq     Df  F value Pr(>F)
#cw        1135.4      1 79181818 <2e-16 ***
#cw:sex       0.5      1    37130 <2e-16 ***
#Residuals    2.9 205565
#---
#Signif. codes:  0 ‘***’ 0.001 ‘**’ 0.01 ‘*’ 0.05 ‘.’ 0.1 ‘ ’ 1

      }

      if (parameterisation == "moncton") {
        m.soft = filter.class(x, "m.soft")
        m.hard = filter.class(x, "m.hard")
        x$mass[m.hard] = x$cw[m.hard]^ 3.098 *  0.0002665
        x$mass[m.soft] = x$cw[m.soft]^ 3.524 *  0.00002995

        #  use same equations as for male ... must fix this
        f.soft = filter.class(x, "f.soft")
        f.hard = filter.class(x, "f.hard")
        x$mass[f.hard] = x$cw[f.hard]^ 3.098 *  0.0002665
        x$mass[f.soft] = x$cw[f.soft]^ 3.524 *  0.00002995
      }

      return(x)
  }