require(compiler)
enableJIT(3)

library(MASS)

generate_state_seq = function( seq_len = 10, states = c('A', 'B'), probs = matrix(NA, 2, 2), initial_state_pos=NA ) {
	ret_seq = rep(0, seq_len)
	rand_list = runif(seq_len)
	if (is.na(initial_state_pos)) { ret_seq[1]=sample.int(nrow(probs), 1) }
	else { ret_seq[1] = initial_state_pos }
	cum_prob = t(apply(probs, 1, cumsum))
	cum_prob[,nrow(cum_prob)] = 1  #Set the last column to 1 to avoid rounding errors
	for (i in 2:seq_len){
		 ret_seq[i] = 1+sum(cum_prob[ret_seq[i-1],] <= rand_list[i] )
	}
	# Could add code to replace the state_index with the state code (as.factor)
	return(ret_seq)
}

rds.mcmc.props = function( S, weights=NULL, method="data.smoothing")
{
	# Returns the Fixed Vector (W) for Transition Probs when weights=NULL
	#
	# Variables to hold calculations
	if (is.null(dimnames(S)[[1]])) {
		 dimnames(S)[1] = list(1:nrow(S))
		 dimnames(S)[2] = list(1:nrow(S))
	}

	groupNames = dimnames(S)[[1]]
	len = length(groupNames)

	#print(len)

 	#Generic Weighted MCMC Estimate
	if (len==2) {
		# Weighted Estimates of Equilibrium Proportions
		# P[A] = S[BA]*D[B]/ ( Sba*Db + Sab*Da )
		if (is.null(weights) ) { weights=rep(1,nrow(S)) }
		P.hat = rep(0 , len)
		for (i in 1:len ) {
			a = i
			b = 3 - i

			P.hat[i] = S[groupNames[b],groupNames[a]]*weights[b] /
			(S[groupNames[b],groupNames[a]]*weights[b] + S[groupNames[a],groupNames[b]]*weights[a])

		}

	} else { # (groupCount > 2)
		P.hat = rep(NA , len)
		if (method=="data.smoothing") {
			if( is.null(weights) ) {
				#print(t(S))
				#print(diag(1,len,len))
				coe = t(S) - diag(1,len,len)
				coe[len,] = rep(1, len )
				b = c(rep(0,len-1),1)
			} else {
				coe = matrix(rep(0,len^2),nrow=len)
				coe[1:len] = c( weights[1] * S[1,] )
				diag(coe) = c(-1*weights*S[,1])
				coe[1,] = rep(1,len)
				b = c(1,rep(0,len-1))
			}
			try((P.hat = solve( coe , b )))
		}
		if (method=="least.squares") {
			stop("*** Unimplemented Method ***")
		}

	}
	names(P.hat) = groupNames
	P.hat[which(P.hat<=0)]=0
	#P.hat[which(is.na(P.hat))]=0
	P.hat
}

fundamental_matrix = function( trans_matrix ) {
	# Calculate the fundamental matrix of transition matrix
	#  Z = (I-P+W)^-1
	W = matrix(rep(rds.mcmc.props(trans_matrix), nrow(trans_matrix)), nrow=nrow(trans_matrix), ncol=nrow(trans_matrix), byrow=TRUE)
	z_inv = diag(x=1, nrow=nrow(trans_matrix), ncol=nrow(trans_matrix) ) - trans_matrix + W

	return( ginv(z_inv) )
}

#asym_mean_count = n*w_j where n is sample size
asym_var_count = function(probs) {
	w = rds.mcmc.props(probs)
	z = fundamental_matrix(probs)
	return( 2* (w*diag(z)) - w - w^2 )
}

# Generate a bootstrapped CI for estimate (no variance in transition probs)
simple_bs = function(S, degree_weights_lists, trials=100, one_tail_alpha=.025 ) {
	bs_results = matrix(nrow=trials, ncol=ncol(S))
	sample_size = length(unlist(degree_weights_lists))
	bs_mean_deg = unlist(lapply(lapply(degree_weights_lists, mean), '^', -1))
	overall_mean = mean(bs_mean_deg)

	state_count = nrow(S)
	#print(bs_results)
	#print(sample_size)
	#print(bs_mean_deg)

	for (j in 1:trials) {
		#Bootstrap a sample composition and transition probs
		bs_sample = generate_state_seq(seq_len=sample_size, probs=S)

		rec = matrix(0, state_count, state_count)
		for (i in 2:length(bs_sample)) {
			rec[bs_sample[i-1], bs_sample[i]] = rec[bs_sample[i-1], bs_sample[i]]+1
		}

		bs.props = prop.table(rec, 1)
		bs.cnum  = as.vector(table( factor(bs_sample, levels=c(1:state_count) ) ))
		#print(bs.cnum)

		#Bootstrap a degree for each group, based on the bootstrapped sample composition
		for (i in 1:length(bs_mean_deg)){
			if (bs.cnum[i]>=1) {
				bs_mean_deg[i] = bs.cnum[i] / sum( sample(degree_weights_lists[[i]], size=bs.cnum[i], replace=TRUE) )
			} else {
				bs_mean_deg[i] = overall_mean
			}
		}

		bs_results[j,] = unlist(rds.mcmc.props(bs.props, bs_mean_deg))
	}
	#print(bs_results)
	bs_ci = as.vector(apply( bs_results, 2, quantile, c(one_tail_alpha, 1-one_tail_alpha), na.rm=TRUE))

	return(bs_ci)
}

# Generate a bootstrapped CI for estimate (with variance in transition probs)
trans_var_bs = function(S, degree_weights_lists, trials=100, one_tail_alpha=.025, fudge=1) {
	bs_results = matrix(nrow=trials, ncol=ncol(S))
	sample_size = length(unlist(degree_weights_lists))
	bs_mean_deg = unlist(lapply(lapply(degree_weights_lists, mean), '^', -1))
	overall_mean = mean(bs_mean_deg)
	state_count = nrow(S)
	#print(bs_results)
	#print(sample_size)
	#print(bs_mean_deg)

	expected_sd = apply(S, c(1,2), function(x) sqrt(x*(1-x)/(sample_size/fudge)) )

	for (j in 1:trials) {
		# Add some variation in the S matrix
		# Create some noise using expected sd
		noise = apply(expected_sd, c(1,2), function(x) rnorm(1, sd=x))

		#if (FALSE) {
			## Correct for dependence of proportions
			## Might only work for 2 states, non-zero recruitment
			noise[,state_count] = noise[,1:(state_count-1)]*-1

			# Re-normalize S after applying noise
			S_noise = S+noise
			S_noise[S_noise<0] = 0
		#}

		S_p = prop.table(S+noise, 1)

		#Bootstrap a sample composition and transition probs
		bs_sample = generate_state_seq(seq_len=sample_size, probs=S_p)

		rec = matrix(0, state_count, state_count)
		for (i in 2:length(bs_sample)) {
			rec[bs_sample[i-1], bs_sample[i]] = rec[bs_sample[i-1], bs_sample[i]]+1
		}

		bs.props = prop.table(rec, 1)
		bs.cnum  = as.vector(table( factor(bs_sample, levels=c(1:state_count) ) ))
		#print(bs.props)
		#print(bs.cnum)

		#Bootstrap a degree for each group, based on the bootstrapped sample composition
		for (i in 1:length(bs_mean_deg)){
			if (bs.cnum[i]>=1) {
				bs_mean_deg[i] = bs.cnum[i] / sum( sample(degree_weights_lists[[i]], size=bs.cnum[i], replace=TRUE) )
			} else {
				bs_mean_deg[i] = overall_mean
			}
		}
		bs_results[j,] = unlist(rds.mcmc.props(bs.props, bs_mean_deg))
	}
	#print(bs_results)
	bs_ci = as.vector(apply( bs_results, 2, quantile, c(one_tail_alpha, 1-one_tail_alpha), na.rm=TRUE))

	return(bs_ci)
}

simple_wts_bs = function(vals_list, weights_list, trials=100, one_tail_alpha=.025 ) {
	bs_results = matrix(nrow=trials, ncol=ncol(S))
	sample_size = length(weights_list)
	state_count = length( unique(vals_list) )
	states = sort(unique(vals_list))
	for (j in 1:trials) {
		#Bootstrap a sample
		bs_sample = sample(vals_list, size=sample_size, replace=TRUE , prob=weights_list )

		bs_results[j,] = prop.table( table(factor(bs_sample, levels=states)) )
	}
	bs_ci = as.vector(apply( bs_results, 2, quantile, c(one_tail_alpha, 1-one_tail_alpha), na.rm=TRUE))

	return(bs_ci)
}

var_wts_bs = function(vals_list, rc_weights_list, dc_weights_list, trials=100, one_tail_alpha=.025 ) {
	bs_results = matrix(nrow=trials, ncol=ncol(S))
	sample_size = length(weights_list)
	states = sort(unique(vals_list))
    state_count = length( states )

	# use vals to partition weights list and get a distribution for each unique val
	rc_lists = list()
	dc_lists - list()

	for (i in state_count) {
		bool_membership = vals_list==state[i]
		rc_lists[[i]] = rc_weights_list[ bool_membership ]
		dc_lists[[i]] = dc_weights_list[ bool_membership ]
	}

	#For each trial
	# permute the weights list within groups

	for (j in 1:trials) {
		#Bootstrap a sample
		bs_sample = sample(vals_list, size=sample_size, replace=TRUE , prob=weights_list )

		bs_results[j,] = prop.table( table(factor(bs_sample, levels=states)) )
	}
	bs_ci = as.vector(apply( bs_results, 2, quantile, c(one_tail_alpha, 1-one_tail_alpha), na.rm=TRUE))

	return(bs_ci)
}

# Generate a bootstrapped CI for estimate (with variance in transition probs)
two_step_trans_var_bs = function(S, degree_weights_lists, trials=100, one_tail_alpha=.05) {
	bs_results = matrix(nrow=trials, ncol=ncol(S))
	sample_size = length(unlist(degree_weights_lists))
	bs_mean_deg = unlist(lapply(lapply(degree_weights_lists, mean), '^', -1))
	state_count = nrow(S)
	#print(bs_results)
	#print(sample_size)
	#print(bs_mean_deg)

	#Generate a set of draws for n_i and n_ij
	w = rds.mcmc.props(S)
	asym_var = asym_var_count(probs)

	# random permutations of the transition matrix S
	S_p = replicate(trials, S)   # random permutations of the transition matrix S
	bs_mean_deg_replicates = replicate(trials, bs_mean_deg)

	# Populate the permutations
	for (i in 1:nrow(S)) {
		# Sample the number of each state in sample
		n_sub_i = round(rnorm(trials, sd=sqrt(asym_var[i] * sample_size))+ sample_size*w[i])

		# Sample the mean degree for each state group
		bs_mean_deg_replicates[i,] = sapply( n_sub_i,  function(x) x / sum( sample(degree_weights_lists[[i]], size=x, replace=TRUE) ) )

		# Sample the transitions from each group ( n_ij, then calculate permuted transitions S )
		S_p[i,,] = prop.table(sapply(n_sub_i, function(x) rmultinom(1, size=x, prob=S[i,] )), 2)
	}
	head(bs_mean_deg_replicates)
	head(S_p)

	for (j in 1:trials) {
		bs_results[j,] = rds.mcmc.props(S_p[,,j], bs_mean_deg_replicates[,j])
	}
	#print(bs_results)
	bs_ci = as.vector(apply( bs_results, 2, quantile, c(one_tail_alpha, 1-one_tail_alpha), na.rm=TRUE))

	return(bs_ci)
}

sim_transition_probs = function(num_trials, sample_size, probs ) {
	# We think the variance for resampled markov chains should be p*(1-p)/n_i when n_i is fixed
	# Need to test that theory with MCMC samples
	results = list()

	for(k in 1:nrow(probs)) {
		results[[k]] = matrix(data=NA, nrow=num_trials, ncol=ncol(probs))
	}

	for (trial in 1:num_trials ) {
		#Generate State Sequence
		foo = generate_state_seq(sample_size, probs=probs)

		state_count = length(unique(foo))
		rec = matrix(0, state_count, state_count)

		for (i in 2:length(foo)) {
			rec[foo[i-1], foo[i]] = rec[foo[i-1], foo[i]]+1
		}

		S = prop.table(rec, 1)

		for(k in 1:nrow(probs)) {
		    results[[k]][trial,] = S[k,]
	    }

	}
	results_list = lapply(results,function(x) apply(x, 2, var))
	return( matrix(unlist(results_list), nrow=nrow(probs), ncol=ncol(probs), byrow=TRUE))
}

sim_transition_probs_mean = function(num_trials, sample_size, probs ) {
	# We think the variance for resampled markov chains should be p*(1-p)/n_i when n_i is fixed
	# Need to test that theory with MCMC samples
	results = list()

	for(k in 1:nrow(probs)) {
		results[[k]] = matrix(data=NA, nrow=num_trials, ncol=ncol(probs))
	}

	for (trial in 1:num_trials ) {
		#Generate State Sequence
		foo = generate_state_seq(sample_size, probs=probs)

		state_count = length(unique(foo))
		rec = matrix(0, state_count, state_count)

		for (i in 2:length(foo)) {
			rec[foo[i-1], foo[i]] = rec[foo[i-1], foo[i]]+1
		}

		S = prop.table(rec, 1)

		for(k in 1:nrow(probs)) {
		    results[[k]][trial,] = S[k,]
	    }

	}
	results_list = lapply(results,function(x) apply(x, 2, mean))
	return( matrix(unlist(results_list), nrow=nrow(probs), ncol=ncol(probs), byrow=TRUE))
}

sim_state_count = function(num_trials, sample_size, probs ) {
	# We think the variance for resampled markov chains should be p*(1-p)/n_i when n_i is fixed
	# Need to test that theory with MCMC samples

	results = matrix(data=NA, nrow=num_trials, ncol=ncol(probs))

	for (trial in 1:num_trials ) {
		#Generate State Sequence
		foo = generate_state_seq(sample_size, probs=probs)

		state_count = length(unique(foo))
		rec = matrix(0, state_count, state_count)

		for (i in 2:length(foo)) {
			rec[foo[i-1], foo[i]] = rec[foo[i-1], foo[i]]+1
		}

		S = rowSums(rec)

		results[trial,] = S

	}

	return( apply(results, 2, var) )

}

two_step_var_est = function(num_replications, sample_size, probs) {
	w = rds.mcmc.props(probs)
	results = matrix(NA,nrow=nrow(probs), ncol=nrow(probs))
	asym_var = asym_var_count(probs)

	for (i in 1:nrow(probs)) {
			n_sub_i = round(rnorm(num_replications, sd=sqrt(asym_var[i] * sample_size))+ sample_size*w[i])
			results[i,] = apply(prop.table(sapply(n_sub_i, function(x) rmultinom(1, size=x, prob=probs[i,] )), 2), 1, var )
	}
	return(results)
}

two_step_var_est_const_sample_size = function(num_replications, sample_size, probs) {
	#This version holds sample size constant by setting the size of the last group as a function of
	# the other groups. Might still produce large samples if the first n-1 groups get large draws
	w = rds.mcmc.props(probs)
	results = matrix(NA,nrow=nrow(probs), ncol=nrow(probs))
	asym_var = asym_var_count(probs)

	n_sub = matrix(0,nrow=nrow(probs),ncol=num_replications)
	for (i in 1:nrow(probs)) {
		if(i==nrow(probs)){
			n_sub[i,] = apply(n_sub, 2, function(x) max(0, sample_size-sum(x)))
		} else {
		    n_sub[i,] = round(rnorm(num_replications, sd=sqrt(asym_var[i] * sample_size))+ sample_size*w[i])
		}
		results[i,] = apply(prop.table(sapply(n_sub[i,], function(x) rmultinom(1, size=x, prob=probs[i,] )), 2), 1, var )
	}
	return(results)
}

two_step_mean_est = function(num_replications, sample_size, probs) {
	w = rds.mcmc.props(probs)
	results = matrix(NA,nrow=nrow(probs), ncol=nrow(probs))
	asym_var = asym_var_count(probs)

	for (i in 1:nrow(probs)) {
			n_sub_i = round(rnorm(num_replications, sd=sqrt(asym_var[i] * sample_size))+ sample_size*w[i])
			results[i,] = apply(prop.table(sapply(n_sub_i, function(x) rmultinom(1, size=x, prob=probs[i,] )), 2), 1, mean )
	}
	return(results)
}

run_interactive = function() {
# --------------------------------------------------------------------------------------------
# ---- this code is protected by the function -------------------------------
# --------------------------------------------------------------------------------------------

degree_listA = c( 350,  150, 100, 300, 700, 200, 200, 300, 300, 200, 100, 400, 200, 150, 100, 200, 50, 500, 30, 500, 500, 25, 150, 50, 500, 150, 300,  250, 400,  250, 100, 200,  100, 150, 150, 60, 500, 100, 200, 200, 150, 20,  200, 500, 100, 700, 300, 200, 500, 125, 500, 250, 100, 200, 30,  150, 400,  100,  100, 100, 200, 100, 250, 50, 60, 100, 150, 500, 200, 200, 100, 100,  100, 150,  70, 400, 25, 50, 200, 300, 250, 50, 200, 100, 500, 150, 600, 100, 500, 150, 200, 300, 200, 150, 300, 100, 500, 200, 200, 100, 125, 50, 500, 50, 200, 500, 500, 300, 200, 100, 70, 300, 75, 300,  500, 100, 100, 125, 500,  200, 200, 500, 25, 80, 150, 120, 150,  500, 250,  150, 25, 30, 50, 30, 200,  70,  100, 100, 50, 100, 100, 100, 50, 100, 400, 25, 200, 800, 30, 400, 100, 100, 150, 40, 250, 300, 200,  300, 200, 800, 400, 400, 500, 450, 600, 300, 70, 100, 100, 300, 75, 500, 40, 400 )

degree_listB = c(585, 400, 300, 100, 383, 700, 80, 150, 300, 850,  200, 300, 150, 300, 300, 200, 150, 100, 150, 600, 300, 50, 300, 100, 700, 300, 100, 35, 70, 500, 150, 200,  20, 250, 100, 500, 20, 150, 90, 200, 20, 150,  30, 100, 200, 100, 60, 600, 100,  375, 50, 200, 300, 100, 100, 200, 75, 100, 220, 300, 500, 400, 100, 50)

degree_weights_list = list(degree_listA^-1, degree_listB^-1)

afterA_probs = c(0.8414634, 0.1585366)
afterB_probs = c(0.5250000, 0.4750000)

probs = matrix( c(afterA_probs, afterB_probs), 2,2,byrow=TRUE)

sample_size = 246

#Get the observed trans
foo = generate_state_seq(sample_size, probs=probs)

state_count = length(unique(foo))
rec = matrix(0, state_count, state_count)

for (i in 2:length(foo)) {
	rec[foo[i-1], foo[i]] = rec[foo[i-1], foo[i]]+1
}

S = prop.table(rec, 1)

cnum = as.vector(table(foo))
# Get Degree Seq by group, invert, bootstrap based on the counts in bootstrapped state_seq

# deg_wt_list is a list of 1/degrees by group, so deg_list[[1]] is the degrees of state index 1
bs_mean_deg = unlist(lapply(lapply(deg_wt_list, mean), '^', -1))  #initialize with group means, probably not necessary

for (i in 1:length(bs_mean_deg)){
	bs_mean_deg[i] = cnum[i] / sum( sample(deg_wt_list[[i]], size=cnum[i], replace=TRUE) )
}

bs_results = c()
sample_size = c()
bs_mean_deg = c()

w_2 = rds.mcmc.props(S)

sim_transition_probs(100000, sample_size, probs)

# [1] 0.0007175294 0.0007175294
# [1] 0.004568726 0.004568726

apply(prop.table(rmultinom(1000000, size = 195, prob = w_2),2), 1, var)
#           1            2
#0.0008414084 0.0008414084

apply(prop.table(rmultinom(1000000, size = 195, prob = afterA_probs),2), 1, var)
# 0.0006855071

apply(prop.table(rmultinom(1000000, size = 50, prob = afterB_probs),2), 1, var)
# 0.004999966

sim_transition_probs(10000, sample_size, probs=matrix(.5,nrow=2, ncol=2))
#0.002080681

apply(prop.table(rmultinom(1000000, size = 195, prob = c(.5, .5)),2), 1, var)
# 0.001282336

apply(prop.table(rmultinom(1000000, size = 50, prob = c(.5, .5)),2), 1, var)
# 0.005005388

#Need to sample number from each group
# VAR[S_j(n)] ~ 2 * w_j * z_jj - w_j- w_j^2

var(rnorm(10000000, sd=sqrt(.343*246))+246*.79 )   #Something like the expected variation of count in each state
# 84.397

var(rnorm(10000000, sd=sqrt(asym_var_count(probs)*246))+246*rds.mcmc.props(probs)[1] )

sim_state_count(100000, 246, probs)
# 83.481

var(rnorm(10000000, sd=sqrt(asym_var_count(probs)*1000))+1000*rds.mcmc.props(probs)[1] )

sim_state_count(10000, 1000, probs)
# 83.481

#Lets simulate the variance of the ratio of n_ij / n_i
#First get the number of n_i:
sample_size = 246
asym_var = asym_var_count(probs)
e_hats = rds.mcmc.props(probs)

n_sub_i = round(rnorm(100000, sd=sqrt(asym_var[1] * sample_size))+ sample_size*e_hats[1])

#n_sub_ij = sapply(n_sub_i, function(x) rmultinom(1, size=x, prob=afterA_probs)

#var_prop = apply(prop.table(sapply(n_sub_i, function(x) rmultinom(1, size=x, prob=afterA_probs) ), 2), 1, var )
apply(prop.table(sapply(n_sub_i, function(x) rmultinom(1, size=x, prob=afterA_probs) ), 2), 1, var )

#.0007 vs .00068  --- not bad, need to check the p=c(.5, .5)

two_step_var_est(100000, 300, matrix(.5,2,2))
#[1,] 0.0008405214 0.0008405214
#[2,] 0.0008378114 0.0008378114

sim_transition_probs(10000, 300, matrix(.5,2,2))
#[1] 0.0008397932 0.0008397932
#[1] 0.0008414575 0.0008414575

# Looks like variance is accurate to within ~2%

# --------------------------------------------------------------------------------------------
# --------------------------------------------------------------------------------------------
# --------------------------------------------------------------------------------------------

}

# Test the percent error in the modeled variance compared to MC
percent_errors_2_groups = function( reps=100, size=300, p_ij=c(.1, .25, .5, .75, .90) ){
	results = matrix(nrow=length(p_ij), ncol=length(p_ij), dimnames=list(p_ij, p_ij))

	for( i in 1:length(p_ij) ) {
		for( j in 1:length(p_ij) ){
			probs = matrix( c(1-p_ij[i], p_ij[j], p_ij[i], 1-p_ij[j]) , 2,2)
			#print(probs)
			mc = sim_transition_probs(reps, size, probs)
			model = two_step_var_est_const_sample_size(reps, size, probs)
			results[i,j] = max((mc-model)/mc)
		}
	}
	results
}


# ......................................................................................
# .........................Exercise 3 - Discrete random variable........................
# ......................................................................................
# ......................................................................................

# If text does not display correctly, set File \Reopen with Encoding ... to UTF-8
# Use CTRL + SHIFT + O to display the contents of the script
# Use CTRL + ENTER to run commands on a single line

#  Examples ####
#
# * Example 1. ####
#
# The owner of the service center offered maintanace to a car dealership that set up car
# rental company. For each car rented through it, they will receive CZK 500 from the car
# rental company. At the same time, however, he undertook to invest CZK 800 in the
# maintenance every day. The number of cars rented through the service center in 1 day
# is described by the following probability function: </br>
#  ![Image-3.png](attachment:image-3.png)
#
# ** 1. a) ####
#
# The value of the probability function for 5 cars was difficult to read. Specify it:
#

x = c(0,1,2,3,4,5,6)
p = c(0.01,0.40,0.25,0.15,0.10,0,0.03)
x
p

1 - sum(p) # Computer arithmetic can be annoying here
round(1 - sum(p), digits=2) # round to the hundredth
p[6] = round(1 - sum(p), digits=2) # the notation for x=5 is the 6th position
p

plot(x, p)

# Probability function
probability_draw = function(x,p){
    plot(x, p, # solid wheels - in actual values
        ylab='p(x)',xaxt='n',pch=19,ylim=c(0,max(p)),main="Probability function")
    lines(c(min(x)-100,max(x)+100),c(0, 0))
    for(i in 1:length(x)){
        lines(c(min(x)-100,max(x)+100), c(p[i],p[i]),
              type = 'l', lty = 3, lwd=0.5) # horizontal grid
        lines(c(x[i],x[i]), c(-0.1,1.1),
              type = 'l', lty = 3, lwd=0.5) # vertical grid
    }
    par(new=TRUE) # that we want to draw in one graph
    plot(x, p*0, # empty circles - where a non-zero value is defined
        ylab='p(x)', xaxt='n', ylim=c(0,max(p)))
    axis(1, at=x,labels=x) # set values to X
    axis(4, at=p,labels=p, las=2, cex.axis=0.7, tck=-.01) # and Y
}

probability_draw(x, p)

# More on plotting in R can be found here:
# http://www.statmethods.net/advgraphs/parameters.html or here
# https://flowingdata.com/2015/03/17/r-cheat-sheet-for-graphical-parameters/ or
# http://bcb.dfci.harvard.edu/~aedin/courses/BiocDec2011/2.Plotting.pdf
#

# ** 1. b) ####
#
# Determine and plot the distribution function of the random variable X, which is
# defined as the number of rented cars.
#

p
F = cumsum(p)
F

plot(x, F, type="s") # simplified distribution function graph

# Function for calculating and plotting the distribution function
distribution_draw = function(x,p){
    F = cumsum(p)
    F_ext = c(0, F) # we stretch F by 0 at the beginning
    x_ext = c(x[1]-1, x, x[length(x)]+1) # axz both sides

    plot(x, F, ylab="F(x)", xaxt='n', ylim=c(0,1), # empty wheels
         type='p', main="Distribution function")
    par(new=TRUE) # that we want to draw in one graph
    plot(x, F_ext[1:(length(F_ext)-1)], # full wheels
         ylab="F(x)", xaxt='n', ylim=c(0,1), type='p', pch=19)

    for(i in 1:(length(x_ext)-1)){
        lines(c(min(x)-100,max(x)+100), c(F_ext[i],F_ext[i]),
              type = 'l', lty = 3, lwd=0.5) # horizontal grid
        lines(c(x_ext[i],x_ext[i]), c(-0.1,1.1),
              type = 'l', lty = 3, lwd=0.5) # vertical grid
        lines(x_ext[i:(i+1)], c(F_ext[i],F_ext[i])) # graph - lines
    }
    axis(1, at=x,labels=x) # set values to X
    axis(4, at=F,labels=F, las=2, cex.axis=0.7, tck=-.01) # a Y
    return(F)
}

distribution_draw(x,p)

# ** 1. c) ####
#
# Determine the mean, variance, standard deviation, and mode of the number of cars
# rented per day.
#

# Mean value
x*p
EX = sum(x*p)
EX

# Scattering
EX2 = sum(x*x*p)  # second general moment
DX = EX2 - EX^2
DX

# Standard deviation
sigma.X = sqrt(DX)
sigma.X

# Functions for calculating basic numerical characteristics
summary_of_RV=function(x,p){
  EX = sum(x*p)
  EX2 = sum(x*x*p)
  DX = EX2-EX^2
  sigma.X = sqrt(DX)
  # write the results to the table
  tab = rbind(EX, DX, sigma.X)
  tab.popis = c("mean","variance","st. dev.")
  rownames(tab) = tab.popis
  return(tab)
}

summary_of_RV(x, p)

# ** 1. d) ####
#
# Determine the probability function and the distribution function of the random
# variable Y, which is defined as the daily income of the service owner.
#

y = 500*x
y

probability_draw(y, p)

# Distribution function
distribution_draw(y,p)

# ** 1. e) ####
#
# Determine the mean, standard deviation, and mode of receipt of the service owner from
# rented cars within one day.
#

summary_of_RV(y,p)

# ** 1. f) ####
#
# Determine the probability that the service owner's income(random variable Y) from car
# rental will exceed his expenses.
#

# profit
z=500*x-800
z

# income exceeds expenses when profit is positive
z > 0

p
sum(p[z>0])

# ** 1. g) ####
#
# Determine the mean, standard deviation, and mode of the random variable Z, which is
# defined as the service owner's profit from rented cars in one day.
#

summary_of_RV(z,p)

# * Example  2 #### ####
#
# For the distribution function of the random variable X: $F(x)=\begin{cases} 0   &
# x \leq -1 \\ 0.3 & -1 < x \leq  0 \\ 0.7 &  0 < x \leq  1 \\ 1   & -1 < x \end{cases}$
#
# ** 2. a) ####
#
# Determine the probability function of a random variable X, its mean and standard
# deviation.
#

F = c(0, 0.3, 0.7, 1)
F
x = c(-1,0,1)
x

diff(F)

p = diff(F)
x
p

probability_draw(x,p)

distribution_draw(x,p)

summary_of_RV(x,p)

# ** 2. b) ####
#
# Random variable Y=1 - 3X, determine P(y), F(y), E(Y), D(Y).
#

y = 1 - 3*x
probability_draw(y,p)

distribution_draw(y,p)   # Nonsensical output - what is the cause?
y
p

y
sort(y)
idx_sorted = order(y) # The order function returns the sorted order indexes
idx_sorted
y = y[idx_sorted]
p_y = p[idx_sorted]
p_y

distribution_draw(y,p_y)

summary_of_RV(y, p_y)

# ** 2. c) ####
#
# Random variable W=$3X^2$, determine P(w), F(w), E(W), D(W).
#

w = 3*x*x
w

probability_draw(w,p)
distribution_draw(w,p)

w
w_uniq = unique(w)
w_uniq
w_sorted = sort(w_uniq)
w_sorted

p_w = w_sorted*0 # initialize an array of the same size
for(i in 1:length(w_sorted)){
    p_w[i] = sum(p[w == w_sorted[i]])
}
p_w

probability_draw(w_sorted,p_w)
distribution_draw(w_sorted,p_w)
summary_of_RV(w_sorted,p_w)

# * Example 3. ####
#
# There are two machines working independently in the workshop. The probability of
# failure of the first machine is 0.2, the probability of failure of the second machine
# is 0.3. The random variable X is defined as the number of machines that have failed at
# the same time. Specify:
#
# ** 3. a) ####
#
# probability function of a random variable X,
#

x = c(0, 1, 2)
x
p1 = 0.2
p2 = 0.3

p = x*0
# we calculate the individual probabilities of the number of broken machines
p[1] = (1 - p1)*(1 - p2) # 0 broken, so both in operation
p[3] = p1*p2 # 2 so broken both
p
1 - sum(p)
p[2] = (1 - p1)*p2 + p1*(1 - p2) # just one - either the first or the second
p

sum(p)

probability_draw(x,p)

# ** 3. b) ####
#
# distribution function of random variable X,
#

distribution_draw(x,p)

# ** 3. c) ####
#
# mean and variance of a random variable X.
#

summary_of_RV(x,p)


rcond_post_beta <- function(y, xm, psi, beta_prior_mean, beta_prior_var){

  mu_beta <- beta_prior_mean
  v_beta <- diag(beta_prior_var)
  v_beta_inv <- diag(1/beta_prior_var)

  xtx <- t(xm)%*%xm

  if(length(y)>0 ){

    post_cov <- chol2inv(chol( v_beta_inv + (1/psi)*xtx))
    post_mean <- post_cov %*% (v_beta_inv %*% mu_beta + (1/psi)*t(xm)%*%y )

  }else{
    post_mean <- mu_beta
    post_cov <- v_beta
  }

  draw <- mvtnorm::rmvnorm(n = 1, mean = post_mean, sigma = post_cov)
  return(draw)
}

cond_post_beta_pdp <- function(beta_vec, y, xm, beta_prior_mean, beta_prior_var){

  eta <- xm %*% beta_vec
  eta <- ifelse(eta < -30, -30, ifelse(eta>5, 5, eta))

  lk <- sum(dbinom(x = y, size = 1, prob = LaplacesDemon::invlogit(eta), log = T))
  pr <- mvtnorm::dmvnorm(x = beta_vec, beta_prior_mean, diag(beta_prior_var), log = T)

  return(lk + pr)
}

rcond_post_psi <- function(beta, y, xm, g1, b1){
  n_k <- length(y)
  if(n_k==0){
    shape_k <- g1
    rate_k <- b1
  }else{
    shape_k <- g1 + n_k/2
    rate_k <- .5*(  sum( (y - xm %*% beta)^2 ) )  + b1
  }
  draw <- invgamma::rinvgamma(n = 1, shape = shape_k, rate = rate_k)
  return(draw)
}

rcond_post_mu_x <- function(x_ck, phi_x, lambda, tau ){
  nvec_k <- length(x_ck)
  mu_mean <- (1/(1/tau + nvec_k/phi_x))*(lambda/tau + sum(x_ck)/phi_x)
  mu_sd <- sqrt( (1/tau + nvec_k/phi_x)^(-1) )
  draw <- rnorm(n = 1, mean = mu_mean, sd =  mu_sd)
  return(draw)
}

rcond_post_phi <- function(mu_x, x, g2, b2){
  n_k <- length(x)
  if(n_k==0){
    shape_k <- g2
    rate_k <- b2
  }else{
    shape_k <- g2 + n_k/2
    rate_k <- .5*(  sum( (x - mu_x )^2 ) )  + b2
  }
  phi_post <- invgamma::rinvgamma(n = 1, shape = shape_k, rate = rate_k)
  return(phi_post)
}

rcond_post_mu_trt <- function(x_ck){
  draw<-rbeta(n = 1,shape1 = 1 + sum(x_ck),
              shape2 = 1 + length(x_ck) - sum(x_ck))
  return(draw)
}

cond_post_alpha <- function(alpha, n, K, nvec){
  lik <- lgamma(alpha) - lgamma(n + alpha) + sum(lgamma(nvec + alpha/K)) - K*lgamma(alpha/K)
  pr <- invgamma::dinvgamma(x = alpha, 1, 1,log = T)
  return(lik + pr)
}

cond_post_pz <- function(gamma, y, xp,
                         gamma_prior_mean,gamma_prior_var){

  eta <- xp %*% gamma
  eta <- ifelse(eta < -10, -10, ifelse(eta>10, 10, eta))
  p <- LaplacesDemon::invlogit(eta)

  lk <- sum(dbinom(x = y, size = 1, prob = p, log = T))
  pr <- mvtnorm::dmvnorm(x = gamma, gamma_prior_mean, diag(gamma_prior_var), log = T)

  return(lk + pr)
}


 DGELSS Example Program Results

 Least squares solution
      0.6344     0.9699    -1.4403     3.3678     3.3992

 Tolerance used to estimate the rank of A
      1.00E-02
 Estimated rank of A
      4

 Singular values of A
      3.9997     2.9962     2.0001     0.9988     0.0025


#[Network analysis](https://en.wikipedia.org/wiki/Network_theory) is a every day task in data analysis. Indeed we often need to know who is linked with who (geographical distance ? Same kind of features ?...)
#[I graph](http://igraph.org/redirect.html) is the perfect package to represent link between objects.

#Let's charge the Igraph package
library("igraph")

#Simulating Data : Mark of 9 students. 3 are known to be strong in Letters, 3 in Art and 3 in Math.
a=c(6,8,11,14,15,14,19,18,20)
b=c(20,20,19,18,18,18,2,4,8)
c=c(3,4,3,15,18,19,2,1,8)
data = matrix(c( a,a+1,a-sample(seq(1,3),9,replace=T) ,a-sample(seq(1,3),9,replace=T),
                 b,b-sample(seq(1,3),9,replace=T),b+sample(seq(1,3),9,replace=T),c,
                 c-sample(seq(1,3),9,replace=T),(b+c)/2) , 9 , 9)
colnames(data)=c("charline", "JP", "Kath", "Gary", "Conor", "Marion", "JB", "gui", "Vincent")
rownames(data)=c("french","phylo","latin","musique","art","sport","math","stat","R")

#Let's have a look to the rough data
library(xtable)
print(xtable(data , caption="rough data", digits=0 ), type = "latex", include.rownames = T ,
      comment=FALSE )

#I calculte correlation between student's Marks. I Want to see who has the same kind of Mark structure
dist=cor(data)
dist[dist<0.5]=0
diag(dist)=0

#Let's make the I-Graph. All the students with a correlation > 0.5 will be linked one to each other on the graph. Students with strong correlation will be closer. People with strong skills in letters, art and math will be Highlighted.
# First I ask to Igraph to calculate the best position of each individuals, doing iterations
g1<-graph.adjacency(dist,weighted="TRUE",mode="undirected")
lay<-layout.fruchterman.reingold(grap=g1,niter=6000)

png("#7_I_graph.png")
par(mar=c(0.5,0.5,0.5,0.5))

# Then I make the plot. I ask to show the know structure of the population
plot.igraph(g1,
            mark.shape=1 ,
            mark.groups=list(c(1:3) , c(4:6) , c(7:9) ) ,
            layout=lay,vertex.label=rownames(dist) ,
            vertex.color="green" ,
            vertex.size=0.5 ,
            edge.arrow.size=13 ,
            main="")

#Finally I add a legend
legend("bottomleft", legend = c("Letter lovers" , "art lovers" , "math lovers"),
       col = rainbow(3, alpha = 0.3) ,
       pch = 15, bty = "n",  pt.cex = 1.5, cex = 0.8 ,
       text.col = "black", horiz = FALSE, inset = c(0.1, 0.1))

#There we can see that the known structure  is relevant. Nevertheless, it looks like the student JB, who is supposed to be strong in Math, is really close to people that are strong in Art. Actually he is strong in both !


## Nesse script vamos gerar dados segundo uma binomial negativa e
## vamos ajustar alguns modelos aos dados e criticá-los

#########
# preparação
library(rstan)
rstan_options(auto_write = TRUE)
options(mc.cores = 4)

set.seed(666)

########
# Simulando os dados
N <- 100
sfactor <- 5 ## Var(X) = sfactor * E[X]
mu <- 10
X <- rnbinom(N, size = mu/(sfactor - 1), mu = mu)
hist(X, probability = TRUE, main = "Ovos de dragão (por macho)")

mean(X)
var(X)

dragonEgg.data <- list(N = N, x = X)
##
poisson.code = "
data{
  int<lower=1> N;
  int<lower=0> x[N];
}
parameters{
  real<lower=0> lambda;
}
model{
  target += poisson_lpmf(x | lambda);
  target += gamma_lpdf(lambda | 1, 1);
}
generated quantities{
 int<lower=0> x_rep[N];
  for(i in 1:N) x_rep[i] = poisson_rng(lambda);
}
"

fit.poisson <- stan(model_code = poisson.code, data = dragonEgg.data)
poisson.replicas <- extract(fit.poisson, 'x_rep')$x_rep

par(mfrow = c(2, 1))

hist(X, probability = TRUE, col = "red", main = "Os dados")
abline(v = mean(X), lwd = 3, lty = 2)
hist(as.vector(poisson.replicas), probability = TRUE,
     main = "Replicatas \n modelo Poisson", xlab = expression(x^{rep}))
abline(v = mean(X), lwd = 3, lty = 2)

par(mfrow = c(1, 1))

# Como nosso modelo "prevê" a média?
medias.poisson <- rowMeans(poisson.replicas)
hist(medias.poisson, probability = TRUE, xlab = expression(bar(x)),  main = "Médias \n modelo Poisson")
abline(v = mean(X), lwd = 3, lty = 2)

# E a variância?

variancias.poisson <- apply(poisson.replicas, 1, var)
hist(variancias.poisson, probability = TRUE,
     main = "Variâncias \n modelo Poisson", xlab = expression(hat(v)),
     xlim = c(min(variancias.poisson), 1.5*var(X)))
abline(v = var(X), lwd = 3, lty = 2)

## Veredito: o modelo não captura corretamente a variabilidade dos dados

## Vamos tentar um modelo hierárquico, mais complexo

poissonBinomial.code = "
data{
  int<lower=1> N;
  int<lower=0> x[N];
}
parameters{
  real<lower=0, upper=1> p;
  real<lower=0> lambda;
}
model{
  target += poisson_lpmf(x | lambda * p );
  target += beta_lpdf(p | 2, 2);
  target += gamma_lpdf(lambda | 1, 1);
}
generated quantities{
 int<lower=0> M_rep[N];
 int<lower=0> x_rep[N];
  for(i in 1:N){
    M_rep[i] = poisson_rng(lambda);
  }
  for(i in 1:N){
    x_rep[i] = binomial_rng(M_rep[i], p);
  }
}
"

fit.poissonBinomial <- stan(model_code = poissonBinomial.code, data = dragonEgg.data)
print(fit.poissonBinomial, pars = c('p', 'lambda') )
poissonBinomial.replicas <- extract(fit.poissonBinomial, 'x_rep')$x_rep

par(mfrow = c(2, 1))

hist(X, probability = TRUE, col = "red", main = "Os dados")
abline(v = mean(X), lwd = 3, lty = 2)
hist(as.vector(poissonBinomial.replicas), xlab = expression(x^{rep}),
     probability = TRUE, main = "Replicatas \n modelo Poisson-binomial")
abline(v = mean(X), lwd = 3, lty = 2)

# "Previsão" da média pelo modelo Poisson-binomial

par(mfrow = c(1, 1))

medias.poissonBinomial <- rowMeans(poissonBinomial.replicas)
hist(medias.poissonBinomial, probability = TRUE,
     xlab = expression(bar(x)),  main = "Médias \n modelo Poisson-binomial")
abline(v = mean(X), lwd = 3, lty = 2)

# Mais uma vez, vamos olhar a variância

variancias.poissonBinomial <- apply(poissonBinomial.replicas, 1, var)
hist(variancias.poissonBinomial, probability = TRUE,
     main = "Variâncias \n modelo Poisson-binomial", xlab = expression(hat(v)),
     xlim = c(min(variancias.poisson), 1.5*var(X)))
abline(v = var(X), lwd = 3, lty = 2)

## Resultado: o modelo ainda é ruim.

# Vamos tentar agora um modelo com uma estrutura hierárquica diferente

poissonGamma.code = "
data{
  int<lower=1> N;
  int<lower=0> x[N];
}
parameters{
  real<lower=0> alpha;
  real<lower=0> beta;
  real<lower=0> lambda[N];
}
model{
  target += poisson_lpmf(x | lambda);
  target += gamma_lpdf(lambda | alpha, beta);
  target += exponential_lpdf(alpha | 1);
  target += exponential_lpdf(beta | 1);
}
generated quantities{
 int<lower=0> x_rep[N];
  for(i in 1:N){
    x_rep[i] = poisson_rng(lambda[i]);
  }
}
"

fit.poissonGamma <- stan(model_code = poissonGamma.code, data = dragonEgg.data)
print(fit.poissonGamma, pars = c('alpha', 'beta') )
poissonGamma.replicas <- extract(fit.poissonGamma, 'x_rep')$x_rep

par(mfrow = c(2, 1))

hist(X, probability = TRUE, col = "red", main = "Os dados")
abline(v = mean(X), lwd = 3, lty = 2)
hist(as.vector(poissonGamma.replicas), xlab = expression(x^{rep}),
     probability = TRUE, main = "Replicatas \n modelo Poisson-gama")
abline(v = mean(X), lwd = 3, lty = 2)

# "Previsão" da média pelo modelo Poisson-Gamma

par(mfrow = c(1, 1))

medias.poissonGamma <- rowMeans(poissonGamma.replicas)
hist(medias.poissonGamma, probability = TRUE,
     xlab = expression(bar(x)),  main = "Médias \n modelo Poisson-Gama")
abline(v = mean(X), lwd = 3, lty = 2)

# Mais uma vez, vamos olhar a variância

variancias.poissonGamma <- apply(poissonGamma.replicas, 1, var)
hist(variancias.poissonGamma, probability = TRUE, xlab = expression(hat(v)) ,
     main = "Variâncias \n modelo Poisson-Gama", xlim = c(min(variancias.poisson), 1.5*var(X)))
abline(v = var(X), lwd = 3, lty = 2)

# Intervalos
quantile(as.vector(poisson.replicas), probs = c(.025, .975))
quantile(as.vector(poissonBinomial.replicas), probs = c(.025, .975))
quantile(as.vector(poissonGamma.replicas), probs = c(.025, .975))
qnbinom(p =  c(.025, .975), size = mu/(sfactor - 1), mu = mu)


##########
plot.hdr2d<-function(x,prob=c(.025,.25,.5,.75,.975),bw=c(5,5),
       cols=gray(  ((length(prob)-1):1)/length(prob)),
       xlim=range(x[,1]),ylim=range(x[,2]),...)
{

  #adapted from package hdrcde by Rob J Hyndman and Jochen Einbeck

  plot(c(0,0),xlim=xlim,ylim=ylim,type="n",...)
  add.hdr2d(x,prob,bw,cols)
}

#########

#########
add.hdr2d<-function(x,prob=c(.025,.25,.5,.75,.975),bw=c(5,5),
       cols=gray(  ((length(prob)-1):1)/length(prob)  ))
{

  require(ash)
  den <- ash2(bin2(x,nbin=round(rep(.5*sqrt(dim(x)[1]),2)) ), bw)
  fxy <- interp.2d(den$x,den$y,den$z,x[,1],x[,2])
  falpha <- quantile(sort(fxy), prob)
  index <- (fxy==max(fxy))
  mode <- c(x[index,1],x[index,2])
  .filled.contour(den$x,den$y,den$z,levels=c(falpha,1e10),col=cols )

}

##########
filledcontour<-function(x,y,z,nlevels=10,col=gray( (nlevels:0)/nlevels ),
                levels=pretty(range(z),nlevels) )
{
   .filled.contour(x,y,z,levels=c(levels,1e10),col=col )
}
##########

#########
interp.2d<- function(x, y, z, x0, y0)
{
    # Bilinear interpolation of function (x,y,z) onto (x0,y0).
    # Taken from Numerical Recipies (second edition) section 3.6.
    # Called by hdr.info.2d
    # Vectorized version of old.interp.2d.
    # Contributed by Mrigesh Kshatriya (mkshatriya@zoology.up.ac.za)

    nx <- length(x)
    ny <- length(y)
    n0 <- length(x0)
    z0 <- numeric(length = n0)
    xr <- diff(range(x))
    yr <- diff(range(y))
    xmin <- min(x)
    ymin <- min(y)
    j <- ceiling(((nx - 1) * (x0 - xmin))/xr)
    k <- ceiling(((ny - 1) * (y0 - ymin))/yr)
    j[j == 0] <- 1
    k[k == 0] <- 1
    j[j == nx] <- nx - 1
    k[k == ny] <- ny - 1
    v <- (x0 - x[j])/(x[j + 1] - x[j])
    u <- (y0 - y[k])/(y[k + 1] - y[k])
    AA <- z[cbind(j, k)]
    BB <- z[cbind(j + 1, k)]
    CC <- z[cbind(j + 1, k + 1)]
    DD <- z[cbind(j, k + 1)]
    z0 <- (1 - v)*(1 - u)*AA + v*(1 - u)*BB + v*u*CC + (1 - v)*u*DD
    return(z0)
}
#########


# File name: mcpi_pbdr.r
# Description: Calculate pi using Monte Carlo
# Run: mpiexec -np 8 Rscript --vanilla mcpi_pbdr.r

# Load pbdMPI and initialize the communicator
library(pbdMPI, quiet = TRUE)
init()

#Load mcpi() function (on each rank)
source("mcpi.r")

# Number of total points to use
n.pts <- 1e7
# Number of points per rank
n.ranks <- comm.size()
n.pts.rank <- ceiling(n.pts / n.ranks)

comm.print(paste('running pbdMPI version with n.pts = ',n.pts,' and nranks = ',n.ranks,' (',n.pts.rank,' pts per rank) \n'))

tm.comp.st = Sys.time()

# Compute pi() on each rank
pi.rank <- mcpi(n.pts.rank)

# Use reduce() to total across ranks
pi.approx <- reduce(pi.rank, op="sum") / n.ranks

tm.comp = as.numeric(Sys.time() - tm.comp.st, units="secs")

pi.err <- abs(pi - pi.approx)/pi

# Output from RANK 0 since reduce() will dump only to 0 by default
comm.print(paste('approximate value of pi is: ',pi.approx,'\n'))
comm.print(paste('            relative error: ',pi.err,'\n'))

comm.print(paste('  computational time = ',tm.comp,'\n'))

# Wrap up
finalize()


# ......................................................................................
# ...........Exercise 5 - Selected distributions of a discrete random variable..........
# ......................................................................................
# ......................................................................................

# If text does not display correctly, set File \Reopen with Encoding ... to UTF-8
# Use CTRL + SHIFT + O to display the contents of the script
# Use CTRL + ENTER to run commands on a single line

#  Overview of distributions and their functions ####
#
# * Introduction: Probability, Cumulative Probability(Distribution) and Quantile ####
# functions
#
# ** Probability function ####
#
# - starts with the letter **d**: $p = P(X = x)$: p=d...(x,...)
#
# ** Cumulative Probability(Distribution Function) ####
#
# - starts with the letter **p**: $p = P(X \leq x)$:p=p...(x,...)
#
# - note that Cumulative probability in R is with the alternative definition $P(X \leq
# t)$
#
# - for our distribution function $F(t) = P(X<t)$: F(t)=p...(t - 1,...)
#
# ** Quantile function ####
#
# - starts with the letter **q**: $p \geq P(X \leq x)$: x=q...(p,...)
#
# - searches for the smallest $x$ for which $P(X \leq x)$ is greater than $p$
#

# * Binomial(Alternative): $X \sim Bi(n, π),X \sim A(π) = Bi(1, π)$ ####
#
# - number of successes in $n$ Bernoulli attempts(or for one attempt in the case of
# Alternative dist.)
#
# - every attempt has a chance of success $π$
#

# Probability function P(X=x)
x = 10   # value for which we are looking for a p-st function
n = 21   # selection range
p = 0.5  # probability of success
dbinom(x, n, p)

dbinom(3.2, n, p)

options(warn=-1) # this can be used to turn off warnings

dbinom(3.2, n, p)

options(warn=0) # this is switched on again

# draw a probability function
x = 0:21 # minimum 0, maximum n has a positive probability
P_x = dbinom(x, n, p)
plot(x, P_x)
grid()

# Cumulative probability function P(X<=x)
x = 10   # value for which we are looking for a value of cumulative prob function
n = 21   # selection range
p = 0.5  # probability of success
pbinom(x, n, p)

# Distribution function F(x)=P(X<x)
x = 10   # value for which we are looking for a value of cumulative prob function
n = 21   # selection range
p = 0.5  # probability of success
pbinom(x, n, p) - dbinom(x, n, p)
# or
pbinom(x - 1, n, p)

# we plot the distribution function
x = 0:21 # minimum 0, maximum n has a positive probability
P_x = dbinom(x, n, p)
F_x = cumsum(P_x)
plot(x, F_x, type='s')
grid()

# or
x = seq(0, 21, 0.01) # minimum 0, maximum n
options(warn=-1)
F_x = pbinom(x, n, p) - dbinom(x, n, p)
plot(x, F_x, cex=0.3)
grid()
options(warn=0)

# check correctness at 10
x = seq(9.9, 10.1, 0.01) # minimum 0, maximum n
options(warn=-1)
F_x = pbinom(x, n, p) - dbinom(x, n, p)
options(warn=0)
plot(x, F_x, cex=0.5)
grid()

# find x for given q: q=P(X<=x)
q = 0.7  # h
n = 21   # selection range
p = 0.5  # probability of success
qbinom(q, n, p)
pbinom(11, n, p)
pbinom(12, n, p)
pbinom(13, n, p)

# Quantile function(inversion of dist. Function): q=F(x)=P(X<x)
q = 0.7   # probability for which we are looking for a quantile
n = 21   # selection range
p = 0.5  # probability of success
qbinom(q, n, p) + 1
pbinom(12 - 1, n, p)
pbinom(13 - 1, n, p)
pbinom(14 - 1, n, p)

# * Hypergeometric: $X \sim H(N, M, n)$ ####
#
# - number of successes in $n$ dependent attempts
#
# - type dependence:
#
#     - $N$ objects,
#
#     - of which $M$ objects with specified property,
#
#     - size of the selection $n$
#
#     - **we do not return back when selecting - the probability of selecting an object
# with a given property changes with each additional selected object**
#
# - **R function takes as parameters * hyper(k, M, N - M, n)**
#
# - k is the number of successes for which we calculate the probability,
#
# - M is the number of objects with the specified property,
#
# - NM is the number of objects without the specified property,
#
# - n is the target size of the selection.
#

# Probability function P(X=x)
x = 5   # value for which we are looking for a p-st function
N = 20  # total number of objects
M = 5   # of which with specified property
n = 10  # selection size
dhyper(x, M, N - M, n)

# plot a probability function
x = 0:5 # minimum 0, maximum n or M has a positive truth.
P_x = dhyper(x, M, N - M, n)
plot(x, P_x)
grid()

# Distribution function F(x)=P(X<x)
x = 5   # value for which we are looking for dist. function
N = 20  # total number of objects
M = 5   # of which with specified property
n = 10  # selection size
phyper(x - 1, M, N - M, n)

# plot the Distribution function
x = 0:5 # minimum 0, maximum n or M has a positive truth.
P_x = dhyper(x, M, N - M, n)
F_x = cumsum(P_x)
plot(x, F_x, type='s')
grid()

# Quantile function(inversion of dist. Function): q=P(X<x)
q = 0.7 # probability for which we are looking for a quantile
N = 20  # total number of objects
M = 5   # of which with specified property
n = 10  # selection size
qhyper(q, M, N - M, n) + 1
phyper(3 - 1, M, N - M, n)
phyper(4 - 1, M, N - M, n)
phyper(5 - 1, M, N - M, n)

# * Negative binomial(Geometric): $X \sim NB(k, π), X \sim Ge(π) = NB(1, π)$ ####
#
# - number of attempts up to $k$-th success(inclusive)
#
# - Every attempt has a chance of success $π$
#
# - **Negatively binomial NV is defined in R as the number of failures before the
# success**
#
# - therefore we will send x - k as the first parameter
#

# Probability function P(X=x)
x = 15   # number of attempts for which we are looking for prob. fc
k = 5    # required number of successes
p = 0.3  # prob. of individual trials
# Note that the first argument must be the number of failures
dnbinom(x - k, k, p)

# let's plot the probability function
x = 0:40 # minimum k, maximum unlimited
P_x = dnbinom(x - k, k, p)
plot(x, P_x)
grid()
# values 0,1,2,3,4 have P(x)=0

# Distribution function F(x)=P(X<x)
x = 15   # number of attempts for which we are looking for prob. fci
k = 5    # required number of successes
p = 0.3  # true individual trials
# Note that the first argument must be the number of failures
pnbinom(x - k - 1, k, p)

# let's draw the Distribution function
x = 0:40 # minimum 0, maximum n or M has a positive prob.
P_x = dnbinom(x - k, k, p)
F_x = cumsum(P_x)
plot(x, F_x, type='s')
grid()

# Quantile function(inversion of dist. Function): q=P(X<x)
q = 0.7  # prob. for quantile
k = 5    # required number of successes
p = 0.3  # true individual trials
qnbinom(q, k, p) + k + 1
pnbinom(19 - k - 1, k, p)
pnbinom(20 - k - 1, k, p)
pnbinom(21 - k - 1, k, p)

# * Poisson: $X \sim Po(λt)$ ####
#
# - number of events in the Poisson process in a closed area(in time, area, volume)
#
# - with occurrence density $λ$
#
# - in time/area/volume of size $t$
#

# Probability function P(X=x)
x = 9       # number of attempts for which we are looking for prob. fci
lambda = 5  # density of occurrence
t = 2       # area/time/volume
lt = lambda*t
dpois(x, lt)

# draw a probability function
x = 0:25 # minimum 0, maximum unlimited
P_x = dpois(x, lt)
plot(x, P_x)
grid()

# Distribution function F(x)=P(X<x)
x = 9       # number of attempts for which we are looking for prob. fci
lambda = 5  # density of occurrence
t = 2       # time/area
lt = lambda*t
ppois(x - 1, lt)

# let's plot the Distribution function
x = 0:25 # minimum 0, maximum n or M has a positive prob.
P_x = dpois(x, lt)
F_x = cumsum(P_x)
plot(x, F_x, type='s')
grid()

# Quantile function(inversion of dist. Function): q=P(X<x)
q = 0.4     # prob. for quantile
lambda = 5  # density of occurrence
t = 2       # time/area
lt = lambda*t
qpois(q, lt) + 1
ppois(9 - 1, lt)
ppois(10 - 1, lt)
ppois(11 - 1, lt)

#  Examples ####
#
# * Example 1. ####
#
# Bridge is played with 52 bridge cards, which are dealt among 4 players. There are
# always 2 players playing together. When dealing(13 cards) you received 2 aces. What is
# the probability that your partner will have the remaining two aces?
#

# X... number of aces among 13 cards
# X~H(N=39, M=2, n=13)
# P(X=2)
M = 2
N = 39 # 52-13
n = 13
# calculation
dhyper(2, M, N - M, n) # which is dhyper(2,2,37,13)

# probability function graph
x = 0:M   # all possible implementations of NV X.
p = dhyper(x, M, N - M, n) # values of the probability function for x
plot(x, p)

# * Example 2. ####
#
# Experiments have shown that a radioactive substance emits within 7.5 s an average of
# 3.87 α-particles. Determine the probability that this substance will emit at least one
# α-particle in 1 second.
#

# X... number of radiated alpha particles during 1 s
# X~Po(lt=3.87/7.5)

lambda = 3.87/7.5 # frequency of occurrence
t = 1 # in 1 second
lt = lambda*t # Poisson distribution parameter

# P(X>=1)=P(X>0)=1 - P(X<=0)
1 - ppois(1 - 1, lt)

# probability function graph
# theoretically up to an infinite number of particles can be emitted,
# from a certain value the probability is negligible
x = 0:10
p = dpois(x, lt) # probability function values for x
plot(x, p)

# * Example 3. ####
#
# A friend sends you to the cellar to bring 4 bottled beers - two 10˚ and two 12˚. You
# don't know where to turn the light on, so you take 4 bottles blindly. How likely were
# you to comply with the requirement if you knew that there were a total of 10 10˚ and 6
# 12˚ in the base?
#

# X... number of 10 ° beers among 4 selected
# X~H(N=16, M=10, n=4)

x = 2
N = 16
M = 10
n = 4

# P(X=2)
dhyper(x, M, N - M, n)

# graph of probability function
x = 0:4    # all possible implementations of NV X.
p = dhyper(x, M, N - M, n) # values of the probability function for x
plot(x, p)

# * Example 4. ####
#
# On average, there are 15 certain microorganisms in one milliliter of a perfectly mixed
# solution. Determine the probability that there will be less than 5 of these
# micro-organisms in a test tube if a sample of 1/2 milliliter is randomly selected.
#

# X... number of microorganisms in 0.5 ml solution
# X~Po(lt=15/2)

lambda = 15
t = 1/2
lt = lambda*t   # Poisson distribution parameter

# P(X<5)=P(X<=4)
ppois(5 - 1, lt)
# or
ppois(5,lt) - dpois(5,lt)

# graph of probability function
# in theory there may be an infinite number of microorganisms in solution,
# from a certain value the probability is negligible
x = 0:20
p = dpois(x, lt) # values of the probability function for x
plot(x, p)

# * Example 5. ####
#
# Throw 15 coins on the table. What is the probability that the number of coins lying
# face up is from 8 to 15?
#

# X... number of coins that fall face up out of a total of 15 coins
# X~Bi(n=15, p=0.5)

n = 15
p = 0.5

# P(8<=X<=15)=P(X<=15) - P(X<8)=P(X<=15) - P(X<=7)
pbinom(15, n, p) - pbinom(7, n, p)

# otherwise: P(8<=X<=15)=P(X>7)=1-P(X<=7)
1 - pbinom(7, n, p)

# graph of probability function
x = 0:15    # all possible implementations of NV X.
p = dbinom(x, n, p) # values of the probability function for x
plot(x, p)

# * Example 6. ####
#
# The probability that we will call the studio of the radio station that has just
# announced a telephone competition is 0.08. What is the probability that we will manage
# to get in on the 4th attempt at the most?
#

# X... number of attempts before we call the radio studio
# X~NB(k=1, p=0.08) or G(0.08)

x = 4
k = 1
p = 0.08

# P(X<=4)
pnbinom(x - k, k, p)

# graph of probability function
# theoretically we can make infinitely many attempts,
# from a certain value the probability is negligible
x = 1:40
p = dnbinom(x - k, k, p) # probability function values for x
plot(x, p)

# * Example 7. ####
#
# In average 10% of the components produce at the factory are defective. What is the
# probability that if we select thirty components from the daily production, at least
# two will be defective?
#

# X... number of defective parts out of 30 selected
# X~Bi(n=30, p=0.1)

n = 30
p = 0.1

# P(X>=2)=1 - P(X<2)=1 - P(X<=1)
1 - pbinom(1, n, p)

# or P(X>=2) all except 0 and 1
1 - (dbinom(0, n, p) + dbinom(1, n, p))

# graph of probability function
x = 0:30            # all possible implementations of NV X.
p = dbinom(x, n, p) # values of the probability function for x
plot(x,p)

# * Example 8. ####
#
# There are 200 parts in stock. 10% of them are defective. What is the probability that
# if we select thirty parts from the warehouse, at least two will be defective?
#

# X... number of defective parts out of 30 selected from 200
# X~H(N=200, M=20, n=30)

N = 200
M = 20
n = 30

# P(X>=2)=1 - P(X<2)=1 - P(X<=1)
1 - phyper(2 - 1, M, N - M, n)

# graph of probability function
x = 0:30   # all possible implementations of NV X.
p = dhyper(x, M, N - M, n) # probability function values for x
plot(x, p)

# * Example 9. ####
#
# In a company, it was found that some illegal software was installed on 33% of
# computers. Determine the probability and distribution function of the number of
# computers with illegal software among the three computers inspected.
#

# X... number of computers with illegal software out of 3 checked
# X~Bi(n=3, p=0.33)

n = 3
p = 0.33

# probabilistic function
x = 0:3  # all possible implementations of NV X
p = dbinom(x, n, p) # probability function values for x

p = round(p, 3) # rounding probabilities to 3 des. places
p[4] = 1 - sum(p[1:3]) # completion of the last value by 1

tab = rbind(x, p) # Create probability function table
rownames(tab) = c("x", "P(x)")
tab

# probability function graph
plot(x, p)

# distribution function
cumsum(p) # simplified distribution function listing

# * Example 10. ####
#
# Sportka is a lottery game in which the bettor bets six numbers out of forty-nine,
# which he expects to fall in a future draw. To participate in the game, it is necessary
# to choose at least one combination of 6 numbers (always 6 numbers per column of 49
# numbers) and use crosses to mark picked numbers. You can bet multiple times by filling
# multiple columns. The bettor wins if he guesses at least three numbers from the drawn
# six numbers. What is the probability that in order for the bettor to win, he will have
# to fill in:
#

# First the probability that we get in one column

# Y... number of guessed numbers in 6 drawn from 49
# Y~H(N=49, M=6, n=6)

N = 49
M = 6
n = 6

# P-st guess at least 3 numbers in one column
# P(Y>=3)=1 - P(Y<3)=1 - P(Y<=2)
pp = 1 - phyper(3 - 1, M, N - M, n)
pp

# ** a) ####
#
# just three columns,
#

# X… the number of columns a bettor will have to fill in order to win
# X~NB(k=1, p=pp)

# a) P(X=3)
k = 1
p = pp

dnbinom(3 - k, k, pp)

# ** b) ####
#
# at least 5 columns,
#

# b) P(X>=5)=1 - P(X<5)=1 - P(X<=4)

1 - pnbinom(5 - k - 1, k, pp)

# ** c) ####
#
# less than 10 columns,
#

# c) P(X<10)=P(X<=9)
pnbinom(10 - k - 1, k, pp)

# * d) ####
#
# more than 5 and at most 10 columns?
#

# P(5<X<=10)=P(X<=10) - P(X<=5)
pnbinom(10 - k, k, pp)-pnbinom(5 - k, k, pp)
# or P(X<11) - P(X<6)
pnbinom(11 - k - 1, k, pp)-pnbinom(6 - k - 1, k, pp)

# * Example 11. ####
#
# The probability of throwing 6 on a 6-wall cube is 1/6. We roll until we roll six 10
# times.
#
# ** a) ####
#
# What is the mean value of the number of throws.
#

# X… rolls the dice before we roll 10 sixes
# X~NB(k=10, p=1/6)

k = 10
p = 1/6

E_X = k/p
E_X

# ** b) ####
#
# How many throws do we have to count on if we want the probability of throwing 10 sixes
# to be at least 70%.
#

# P(X<=k)>=0.7
qnbinom(0.7, k, p) + k


#basics

max(x,na.rm=TRUE) #Find the maximum value in the vector x, exclude missing values
min(x, na.rm=TRUE)
mean(x,na.rm=TRUE)
median(x,na.rm=TRUE)
sum(x, na.rm=TRUE)
var(x,na.rm=TRUE) #produces the variance covariance matrix
sd(x,na.rm=TRUE) #standard deviation
mad(x,na.rm=TRUE) #(median absolute deviation)
fivenum(x,na.rm=TRUE) #Tukey five numbers min, lower hinge, median, upperhinge, max
table(x) #frequency counts of entries, ideally the entries are factors (although it works with integers or even reals)

abs(x) #takes the absolute value of x
log(x,base = y) #Takes the log of x with base y; if base is not specified, returns the natural log
exp(x) #returns the exponential of x
sqrt(x) #Returns the square root of x
factorial(x) #Returns the factorial of x (x!)
choose(x, y) #Returns the number of possible combinations when drawing y elements at a time from x possibilities
round(x, digits = y) #Rounds x to y places
floor(x) #rounds down to the nearest int
ceiling(x) #rounds up to the nearest int
signif(x, digits = y) #rounds to that specified number of significant digits


fibonacci_step <- function(a, b) {
    list(b, a + b)
}

gross <- 0
lst <- list(1, 2)
while (lst[[1]] < 4e6) {
    if (lst[[1]] %% 2 == 0) {
        gross <- gross + lst[[1]]
    }
    lst <- do.call(fibonacci_step, lst)
}

cat(gross, "\n")


# 4E1

# The likelihood is y_i ~ Normal(mu, sigma)

# 4E2

# There are 2 parameters

# 4E3

# Bayes' Theorem:
# p(a | b) = p(b | a) p(a) / p(b)

# Model:
# y_i ~ Normal(mu, sigma)
# mu ~ Normal(0, 10)
# sigma ~ Exponential(1)

# pr(y_i | mu, sigma) = Normal(y_i | mu, sigma)
# pr(mu) = Normal(mu | 0, 10)
# pr(sigma) = Exponential(sigma | 1)

# So:

# pr(mu, sigma | y_i ) = (pr(y_i | mu, sigma) * pr(mu) * pr(sigma))
#                        / ( integral(pr(y_i | mu, sigma)
#                          * pr(mu) * pr(sigma))d y )

# pr(mu, sigma | y_i ) = (Normal(y | mu, sigma)
#                       * Normal(mu | 0, 10) *
#                       * Exp(sigma | 1))
#            / integral(Normal(y | mu, sigma)
#             * Normal(0, 10)
#             * Exp(1)) dmu dsigma

# Yeah I don't understand this.

# 4E4

# The linear model is u_i = a + b * x_i

# 4E5

# 3 parameters, a, b, sigma in the posterior.
# The mean is defined by a and b, as such isn't a parameter.

# 4M1

# Model:
# y_i ~ Normal(mu, sigma)
# mu ~ Normal(0, 10)
# sigma ~ Exponential(1)

# Recall: The prior predictive simulation is plugging in the prior parameter
# samples into the *likelihood estimator*.

# So:

# Likelihood estimator

size <- 1e4

likelihood <- function(mu_samples, sigma_samples) {
	 rnorm(size, mu_samples, sigma_samples)
}

mu_samples <- rnorm(size, 0, 10)
sigma_samples <- rexp(size, 1)

prior_predictive_samples <- likelihood(mu_samples, sigma_samples)
dens(prior_predictive_samples)

# Note that we end up sampling through layers when doing Posterior pred sim.

# 4M4
# y_i ~ dnorm(mu, sigma)
# mu ~ dnorm(0, 10)
# sigma ~ dexp(1)

# 4M3
# y ~ Normal(mu, sigma)
# mu = a + b*x
# a ~ Normal(0, 10)
# b ~ Uniform(0, 1),
# sigma ~ Exponential(1)

# 4M4
# Measure student heights for 3 years. Linear regression: height vs year.
# h_i ~ dnorm(mu_i, sigma)
# mu_i = a + b * ( year_i - year_bar)
# a <- dnorm(100, 20)
# b <- dunif(5, 20)
# sigma <- dunif(0, 15)

# prior-pd:
plot(NULL, xlim=c(0, 3), ylim=c(50, 250), xlab="year", ylab="height")
N <- 100
year_bar <- 2
a_sample <- rnorm(N, 100, 20)
b_sample <- log_normal(N, 5, 20)
sigma_sample <- runif(N, 0, 8)

for (i in 1:N) curve(
	a[i] + b[i] * (x - year_bar),
	from=0,
	to=3,
	add=TRUE,
	col=col.alpha('black', .2)
)

# 4M7
library(rethinking)
data(Howell1); d <- Howell1; d2 <- d[ d$age >= 18, ]

m4.3_revised <- quap(
  alist(
    # likelihood
    height ~ dnorm(mu, sigma),
    # Linear predictor
    mu <- alpha + beta * ( weight),
    # priors
    alpha ~ dnorm(178, 20),
    beta ~ dlnorm(0, 1),
    sigma ~ dunif(0, 50)
  ), data=d2
)

# > vcov(m4.3_revised)
#              alpha          beta         sigma
# alpha  3.601407563 -0.0784370308  0.0093616751
# beta  -0.078437031  0.0017437116 -0.0002043995
# sigma  0.009361675 -0.0002043995  0.0365751541

# > vcov(m4.3)
#               alpha          beta         sigma
# alpha  7.306632e-02 -4.238715e-08  6.151697e-05
# beta  -4.238715e-08  1.757593e-03 -2.517741e-05
# sigma  6.151697e-05 -2.517741e-05  3.654026e-02

analyze <- m4_7analyze(model) {
	weight.seq <- seq(from=25, to=70, by=1)
	mu_revised <- link(model, data=data.frame(weight=weight.seq))
	mu_revised.mean <- apply(mu_revised, 2, mean)
	mu_revised.pi <- apply(mu_revised, 2, PI, prob=.89)

	heights <- sim(model, data=list(weight=weight.seq))
	heights.pi <- apply(heights, 2, PI, prob=.89)

	plot(
		d2$height ~ d2$weight,
		xlim=range(d2$weight),
		col=col.alpha(rangi2, .8)
	)

	lines(weight.seq, mu_revised.mean)
	shade(mu_revised.pi, weight.seq)
	shade(heights.pi, weight.seq)
}


simulate_bayesian = function(steps, phi, I0) {
  discrete_pchisq = diff(pchisq(0:steps, df=6))
  beta = function(t, tau) {
      return(phi * discrete_pchisq[tau])
  }
  # simulate a sequence of incident cases
  I = I0
  expected = I0
  expected_conditional = I0
  for (t in 2:steps) {
    I = c(I, 0) # so I[t] = 0
    expected = c(expected, 0)
    expected_conditional = c(expected_conditional, 0)
    for (tau in 1:(t - 1)) {
      I[t] = I[t] + (rpois(1, lambda=beta(t, tau)) * I[t - tau])
      expected[t] = expected[t] + beta(t, tau) * expected[t - tau]
      expected_conditional[t] = expected_conditional[t] + beta(t, tau) * I[t - tau]
    }
  }
  return(list("I"=I, "expected"=expected, "expected_conditional"=expected_conditional,
              "omega"=discrete_pchisq))
}

simulate_impartial = function(steps, beta, tau1, tau2, I0) {
  "
  Simulate Cerón's impartial model.

  Parameters
  ----------
  steps : numeric
    Number of steps in the simulation.
  beta : numeric vector
    Series where beta[t] is the expected number of people an infectious patient
    will infect in step t.
  tau1 : numeric
    Expected number of days since exposure to infection onset.
  tau2 : numeric
    Expected number of days a patient remains infectious.
  I0 : numeric
    Number of intial just-infectious cases.
  "
  # initialize simulated vectors to be returned
  E = 0
  N = I0
  I = I0
  expected_I = I0
  expected_E = 0
  expected_N = I0
  # carry out simulation and append to those vectors
  for (t in 1:(steps - 1)) {
    I = c(I, rbinom(1, size=E[t], prob=1 / tau1))
    E = c(E, E[t] - I[t + 1] + rpois(1, lambda=beta[t] * N[t]))
    N = c(N, N[t] + I[t + 1] - rbinom(1, size=N[t], prob=1 / tau2))
    # track expected values
    expected_I = c(expected_I, expected_E[t] / tau1)
    expected_E = c(expected_E, expected_E[t] - expected_I[t + 1] + expected_N[t] * beta[t])
    expected_N = c(expected_N, expected_I[t + 1] + expected_N[t] * (1 - (1 / tau2)))
  }
  # calculate theoretical values
  R = beta * tau2
  f_inc = dgeom(1:steps - 1, p=1 / tau1)
  f_inf = dgeom(1:steps - 1, p=1 / tau2)
  omega = NULL
  for (tau in 1:steps) {
    omega = c(omega, 0) # so omega[tau] = 0
    for (tau_prime in 0:(tau - 1)) {
      omega[tau] = omega[tau] +
                   pgeom(tau_prime - 1, p=1 / tau2, lower.tail=FALSE) *
                   dgeom(tau - tau_prime - 1, p=1 / tau1)
    }
  }
  omega = omega / tau2
  # alternative tau calculation
  omega_alt = rep(0, length=steps)
  prob1 = dgeom((-1):(2 * steps), p=1/tau1)
  prob2 = dgeom((-1):(2 * steps), p=1/tau2)
  for(i in 1:(steps + 1)){
    for(j in 1:(steps + 1)){
      if(i + j - 2 < steps){
        # omega_alt[i+j-1] = omega_alt[i+j-1] + dgeom(i-2, p=1/tau1) *
        #                    (dgeom(2*j - 2, p=1/tau2) + dgeom(2*j - 3, p=1/tau2))
        omega_alt[i+j-1]=omega_alt[i+j-1]+prob1[i]*(prob2[2*j]+prob2[2*j-1])
      }
    }
  }
  # supress starting 0
  omega_alt = c(omega_alt[2:steps], 0)
  return(list(
    "I"=I, "E"=E, "N"=N, "expected_I"=expected_I, "R"=R, "f_inc"=f_inc,
    "f_inf"=f_inf, "steps"=steps, "tau1"=tau1, "tau2"=tau2, "omega"=omega,
    "omega_alt"=omega_alt
  ))
}

simulate_inseparable_beta = function(steps, phi, tau0, I0) {
  t0 = floor(steps / 2)
  discrete_pchisq = diff(pchisq(0:steps, df=6))
  beta = function(t, tau) {
    if (t <= t0) {
      return(phi * discrete_pchisq[tau])
    } else {
      if (tau > tau0) {
        return(0)
      } else {
        return (phi * discrete_pchisq[tau] / pchisq(tau0, df=6))
      }
    }
  }
  omega = function(t, tau) {
    if (t <= t0) {
      return(discrete_pchisq[tau])
    } else {
      if (tau > tau0) {
        return(0)
      } else {
        return (discrete_pchisq[tau] / pchisq(tau0, df=4))
      }
    }
  }
  # simulate a sequence of incident cases
  I = I0
  expected = I0
  expected_conditional = I0
  for (t in 2:steps) {
    I = c(I, 0) # so I[t] starts at 0
    expected = c(expected, 0)
    expected_conditional = c(expected_conditional, 0)
    for (tau in 1:(t - 1)) {
      I[t] = I[t] + (rpois(1, lambda=beta(t, tau)) * I[t - tau])
      expected[t] = expected[t] + beta(t, tau) * expected[t - tau]
      expected_conditional[t] = expected_conditional[t] + beta(t, tau) * I[t - tau]
    }
  }
  return(list("I"=I, "expected"=expected, "expected_conditional"=expected_conditional,
              "omega"=omega))
}


#' Compute the squared coherence spectrum of two timeseries.
#'
#' @param t1 Sampling times of timeseries 1.
#' @param x1 Value of timeseries 1 at each sample time.
#' @param t2 Sampling times of timeseries 2.
#' @param x2 Value of timeseries 2 at each sample time.
#' @param omega Angular frequencies to evaluate periodogram at.
#' @param demeaned Whether timeseries has already been de-meaned.
#' @param standardized Whether timeseries has already been standardized.
#'
#' @return Values of squared coherence spectrum at angular frequencies specified.
#'
#' @examples
#' squared.coherence.spectrum(1:10, sin(1:10), 1:10, cos(1:10), 2*pi/1:10, FALSE, FALSE)
#'
#' @export
squared.coherence.spectrum <- function(t1, x1, t2, x2, omega,
                                       demeaned = FALSE, standardized = FALSE) {

    ## De-mean and standardize, if not already done. ##
    if (!demeaned) {
        x1 <- x1 - mean(x1)
        x2 <- x2 - mean(x2)
    }
    if (!standardized) {
        x1 <- x1 / sd(x1)
        x2 <- x2 / sd(x2)
    }

    tau1 <- tau(t1, omega)
    tau2 <- tau(t2, omega)

    a1 <- periodogram.component(t1, x1, omega, tau1, "cos")
    a2 <- periodogram.component(t2, x2, omega, tau2, "cos")
    b1 <- periodogram.component(t1, x1, omega, tau1, "sin")
    b2 <- periodogram.component(t2, x2, omega, tau2, "sin")

    co.spectrum <- a1*a2 + b1*b2
    quad.spectrum <- a1*b2 - a2*b1

    cross.amplitude.spectrum.squared <- co.spectrum^2 + quad.spectrum^2

    power.spectrum1 <- 0.5 * (a1^2 + b1^2)
    power.spectrum2 <- 0.5 * (a2^2 + b2^2)

    cross.amplitude.spectrum.squared / (power.spectrum1 * power.spectrum2)

}


library(shiny)
library(rsconnect)
library(ggplot2)

#############################################################
# Set the baseline parameters
#############################################################
base_sI <- .2
base_gL <- .01
base_gA <- .02
base_delta <- .05
base_alpha <- .3
base_A <- 1
base_kystar <- base_sI/(base_gL+base_gA+base_delta)
base_K <- base_kystar^(1/(1-base_alpha))
base_timeT <- 50

#############################################################
# Define UI ----
#############################################################
ui <- fluidPage(
  withMathJax(),
  titlePanel("Basic Solow Model"),

  sidebarLayout(
    sidebarPanel(

      h4("Set parameters"),
      actionButton("reset", "Reset to baseline"),
      sliderInput("alt_sI", h6('New capital share of GDP \\(s_I\\)'),
                  min = 0, max = 1, value = base_sI),
      sliderInput("alt_gL", h6("Population growth rate \\(gL\\)"),
                  min = -.1, max = .1, value = base_gL),
      sliderInput("alt_gA", h6("Productivity gorwth rate \\(gA\\)"),
                  min = -.1, max = .1, value = base_gA),
      sliderInput("alt_delta", h6("Depreciation rate \\(\\delta\\)"),
                  min = 0, max = 1, value = base_delta),
      sliderInput("alt_alpha", h6("Capital elasticity \\(\\alpha\\)"),
                  min = 0, max = 1, value = base_alpha),
      sliderInput("alt_K", h6("Initial capital stock \\(K_0\\)"),
                  min = 0, max = 10, value = base_K,step = 0.1),
      sliderInput("alt_A", h6("Initial Productivity \\(A_0\\)"),
                  min = 0, max = 10, value = base_A, step = 0.1),
      sliderInput("timeT", h6("Number of periods"),
                  min = 0, max = 300, value = base_timeT, step = 1)
      ), # end sidebar panel

    mainPanel(

      tabsetPanel(type = "tabs",
                  tabPanel("K/Y ratio",
                           br(),
                           p("The baseline is that the economy is on a BGP, so the actual K/Y is constant.
                             As you adjust the parameters to the left, there may be a new BGP, or actual K/Y may
                             not be on the BGP any more. Black graphs the actual path of K/Y, blue the baseline BGP,
                             and green is the new BGP based on your choice of parameters."),
                           br(),
                           p("Be sure you understand why some adjustments to parameters create a new BGP, and why
                             some adjustments only push actual K/Y off of the BGP."),
                           plotOutput("kygraph",width = "100%") ),
                  tabPanel("Log GDP p.c.",
                           br(),
                           p("This has the same idea the K/Y ratio. Black is the actual path of GDP per capita.
                             Green is the BGP from the parameters you set, and blue is the original BGP."),
                           br(),
                           plotOutput("lnygraph",width = "100%") ),
                  tabPanel("Growth rate",
                           br(),
                           p("The colors work the same with the growth rate of GDP per capita. Make sure you
                             understand how this growth rate is related to the path of log GDP per capita."),
                           br(),
                           plotOutput("gygraph",width = "100%") ),
                  tabPanel("K/Y dynamics",
                           br(),
                           p("This graph is different. It shows the relationship of the growth rate in K/Y and
                             the level of K/Y. The negative slope established the stability of the Solow model.
                             Changes in some parameters shift the theoretical curves here, implying different
                             steady state K/Y ratios where the growth rate is zero."),
                           br(),
                           p("The black dots indicate the actual K/Y ratio and growth rate over time. In the
                             baseline, all these dots are at the steady state point. If you adjust parameters
                             you'll see these spread out and show you how K/Y and the growth rate of K/Y evolved.
                             See how they follow the green path based on the new BGP."),
                           br(),
                           plotOutput("gkygraph",width = "100%") )
      ) # end tabset

      ) # end main panel
  ) # end ui
)
#############################################################
# Define server logic ----
#############################################################
server <- function(input, output, session) {

  # Reset parameters
  observeEvent(input$reset, {
    updateSliderInput(session,'alt_sI',value = base_sI)
    updateSliderInput(session,'alt_gL',value = base_gL)
    updateSliderInput(session,'alt_gA',value = base_gA)
    updateSliderInput(session,'alt_delta',value = base_delta)
    updateSliderInput(session,'alt_alpha',value = base_alpha)
    updateSliderInput(session,'alt_K',value = base_K)
    updateSliderInput(session,'alt_A',value = base_A)
    updateSliderInput(session,'timeT',value = base_timeT)
  })

  # Simple function to calculate the new  steady state K/Y ratio for display
  output$kystar <- renderText(
    {
    paste("K/Y*:",
          input$alt_sI/(input$alt_delta+input$alt_gA+input$alt_gL))
    }
  )

  # Function to combine alternative and baseline inputs, generate dataframe
  # containing time series of outcomes
  GraphData <- reactive({
    t <- c(0:input$timeT) # vector of periods up to input time
    df <- data.frame(t) # create dataframe to hold outcomes
    alt_kystar <- input$alt_sI/(input$alt_delta+input$alt_gA+input$alt_gL) # alt ss KY
    alt_ky <- (input$alt_K/input$alt_A)^(1-input$alt_alpha) ## actual starting KY

    # Formula to fill in per-period actual KY ratio
    df$ky <- alt_kystar*(1-exp(-(1-input$alt_alpha)*(input$alt_delta+input$alt_gA+input$alt_gL)*df$t)) + alt_ky*exp(-(1-input$alt_alpha)*(input$alt_delta+input$alt_gA+input$alt_gL)*df$t)

    df$kyalt <- alt_kystar # fill df with alt ss KY
    df$kybase <- base_kystar # fill df with base ss KY

    # Fill df with series on log GDP per capita
    df$lny <- (input$alt_alpha/(1-input$alt_alpha))*df$ky + log(input$alt_A) + input$alt_gA*df$t
    df$lnyalt <- (input$alt_alpha/(1-input$alt_alpha))*df$kyalt + log(input$alt_A) + input$alt_gA*df$t
    df$lnybase <- (base_alpha/(1-base_alpha))*df$kybase + log(base_A) + base_gA*df$t

    # Fill df with series on growth rate of GDP per capita
    df$gky <- (1-input$alt_alpha)*(input$alt_sI/df$ky-input$alt_gL -input$alt_gA- input$alt_delta)
    df$gy <- (input$alt_alpha/(1-input$alt_alpha))*df$gky + input$alt_gA
    df$gyalt <- input$alt_gA
    df$gybase <- base_gA

    df$tick <- df$ky # for graphing purposes later
    return(df)
  })

  output$kygraph <- renderPlot(
    {
      ggplot(GraphData(), aes(t,value,colour=variable)) +
        geom_line(aes(y = ky, color = "black"),size=1) +
        geom_line(aes(y = kybase, color="blue"), linetype="dashed",size=1) +
        geom_line(aes(y = kyalt, color="green"), linetype="dashed",size=1) +
        xlab("Time") +
        ylab("Capital/output ratio") +
        ylim(0, 5) +
        theme_light() +
        ggtitle("Capital/output ratio over time") +
        scale_color_identity(name = "Models",
                             breaks = c("black", "green", "blue"),
                             labels = c("Actual", "New BGP", "Old BGP"),
                             guide = "legend")
    }
  ) # end ky graph

  output$lnygraph <- renderPlot(
    {
      ggplot(GraphData(), aes(t,value,colour=variable)) +
        geom_line(aes(y = lny, color = "black"),size=1) +
        geom_line(aes(y = lnybase, color="blue"), linetype="dashed",size=1) +
        geom_line(aes(y = lnyalt, color="green"), linetype="dashed",size=1) +
        xlab("Time") +
        ylab("Log GDP per capita") +
        ylim(0, 3) +
        theme_light() +
        ggtitle("GDP per capita over time") +
        scale_color_identity(name = "Models",
                             breaks = c("black", "green", "blue"),
                             labels = c("Actual", "New BGP", "Old BGP"),
                             guide = "legend")
    }
  ) # end lny graph

  output$gygraph <- renderPlot(
    {
      ggplot(GraphData(), aes(t,value,colour=variable)) +
        geom_line(aes(y = gy, color = "black"),size=1) +
        geom_line(aes(y = gybase, color="blue"), linetype="dashed",size=1) +
        geom_line(aes(y = gyalt, color="green"), linetype="dashed",size=1) +
        xlab("Time") +
        ylab("Growth rate of GDP p.c.") +
        theme_light() +
        ylim(-.05, .07) +
        ggtitle("Growth rate of GDP p.c. over time") +
        scale_color_identity(name = "Models",
                             breaks = c("black", "green", "blue"),
                             labels = c("Actual", "New BGP", "Old BGP"),
                             guide = "legend")
    }
  ) # end gy graph

  output$gkygraph <- renderPlot(
    {
      tick <- seq(0,6,.1) # arbitrary kal values
      df <- data.frame(tick) # create dataframe
      df$gky <- (1-input$alt_alpha)*(input$alt_sI/df$tick-input$alt_gL -input$alt_gA- input$alt_delta)
      df$gkybase <- (1-base_alpha)*(base_sI/df$tick-base_gL -base_gA- base_delta)
      alt_kystar = (input$alt_sI/(input$alt_gL + input$alt_gA + input$alt_delta))

      ggplot(df, aes(x=tick)) +
        geom_line(aes(y = gky, color = "green"),size=1) +
        geom_line(aes(y = gkybase, color="blue"), linetype="dashed",size=1) +
        geom_point(data=GraphData(),y=GraphData()$gky, color="black") +
        geom_hline(yintercept=0, linetype="dotted", color = "red") +
        geom_vline(xintercept=base_kystar, linetype="dotted", color = "red") +
        geom_vline(xintercept=alt_kystar, linetype="dotted", color = "red") +
        xlab("K/Y ratio") +
        ylab("Growth rate of K/Y") +
        theme_light() +
        ylim(-.1,.15) +
        ggtitle("Growth rate of K/Y vs. K/Y") +
        scale_color_identity(name = "Models",
                             breaks = c("green", "blue"),
                             labels = c("New BGP", "Old BGP"),
                             guide = "legend")
    }
  ) # end gky graph

} # end server

# Run the app ----
shinyApp(ui = ui, server = server)


# intersects line x+t*v with G*x<h polytope
# returns: c(X1,minT), where X1 is the intersection points, and minT is the T values at intersection point..
intersectLineWithPlanes <- function(G,h,X,V){

  #hGX= ( G %*% X )  - h
  hGX = sweep( -G %*% X , 2 , h, '+',check.margin = FALSE)

  T = hGX / G %*% V

  T[T<0] = Inf

  minT = apply(T,2,min)

  X1 = sweep( X , 2 , V %*% minT , '+',check.margin = FALSE)

  #ret = c(X1,minT)
  ret = vector('list',2);
  ret[[1]] = X1
  ret[[2]] = minT
  return(ret);
}

# compute hr step
hrstep_unif <- function (G,h,X) {

  d=ncol(G)
  m=nrow(G)
  n=ncol(X);

  # compute random directions:
  vr = matrix(rnorm(n*d),nrow=d)
  vr = vr / apply(vr,2,sum)

  # compute intersections:
  tbr = intersectLineWithPlanes(G,h,X,vr)
  tar = intersectLineWithPlanes(G,h,X,-vr)
  ta = -tar[[2]]
  tb = tbr[[2]]

  # compute random new points:
  r01 = matrix(runif(n))
  t01 = ta + (tb-ta) * t(r01)

  Xnext = X + sweep( vr , 2 , t01 , '*')# ( t01 * vr )
  return(Xnext)
}

# performs hr step, using a trivial method to estimate 1d density
# ns2d is number of samples for 1d density estim
hrstep_01 <- function (G,h,f,X,ns1d) {
  d=ncol(G)
  m=nrow(G)
  n=ncol(X);

  # compute random directions:
  vr = matrix(rnorm(n*d),nrow=d)
  vr = vr / repmat(colSums(vr^2),d,1)

  # compute intersections:
  tbr = intersectLineWithPlanes(G,h,X,vr)
  tar = intersectLineWithPlanes(G,h,X,-vr)
  ixa = tar[[1]]
  ixb = tbr[[1]]

  # compute random new points:
  uu = runif(n)
  #loop over samples and process each separately..
  for(zi in 1:n){
    #xx = sweep( ixa[,zi,drop=FALSE] , 2 , sweep( (ixb[,zi,drop=FALSE]-ixa[,zi,drop=FALSE]),2, seq(0,1,length=(ns1d+2)) ,'*' ) , '+')
    #xx = bsxfun( '+' , ixa[,zi,drop=FALSE] , bsxfun('*',(ixb[,zi,drop=FALSE]-ixa[,zi,drop=FALSE]),seq(0,1,length=(ns1d+2))) )
    #xx = outer( (ixb[,zi,drop=FALSE]-ixa[,zi,drop=FALSE]),seq(0,1,length=(ns1d+2)) )
    xx = repmat( ixa[,zi,drop=FALSE] , 1 , ns1d+2 ) +  ( (ixb[,zi,drop=FALSE]-ixa[,zi,drop=FALSE]) %*% seq(0,1,length=(ns1d+2)) )
    ff   = apply(xx[,-c(1,ns1d+2)],2,f)
    ffcs = cumsum(ff);
    ffcs = ffcs / tail(ffcs,1)

    # now draw unif. rd to get next point:
    u  = uu[zi];
    # find first entry larger than u
    ux = min(which(ffcs>u))
    # par(mfrow=c(2,1)); plot(ff); plot(ffcs)
    # pos now is: center of xx[ux] andxx[ux+1]
    xn = 0.5*(xx[,ux] + xx[,ux+1])

    X[,zi] = xn
  }
  return(X)
}

# compute hr steps
# nsteps
hr_unif <- function(G,h,X,nsteps) {

  cs = 0
  XX = vector('list',length(nsteps))

  ii = 1;
  for(nsi in nsteps){
    stepsi = nsi-cs;
    for( zi in 1:stepsi ){
      X = hrstep_unif(G,h,X)
    }
    XX[[ii]] = X;
    ii = ii+1
    cs = nsi;
  }
  return(XX);
}

hr <- function(G,h,f,X,nsteps,ns1d) {

  cs = 0
  XX = vector('list',length(nsteps))

  ii = 1;
  for(nsi in nsteps){
    stepsi = nsi-cs;
    for( zi in 1:stepsi ){
      X = hrstep_01(G,h,f,X,ns1d)
    }
    XX[[ii]] = X;
    ii = ii+1
    cs = nsi;
  }
  return(XX);
}


# Utilities - basics

# 1. Mathematical
# round: round the values to 0 decimal places by default

# The errors vector has already been defined for you
errors <- c(1.9, -2.6, 4.0, -9.5, -3.4, 7.3)

# Sum of absolute rounded values of errors
sum(abs(round(errors)))

# 2. Data
# seq(): Generate sequences, by specifying the from, to, and by arguments.
# rep(): Replicate elements of vectors and lists.
# sort(): Sort a vector in ascending order. Works on numerics, but also on character strings and logicals.
# rev(): Reverse the elements in a data structures for which reversal is defined.
# str(): Display the structure of any R object.
# append(): Merge vectors or lists.
# is.*(): Check for the class of an R object.
# as.*(): Convert an R object from one class to another.
# unlist(): Flatten (possibly embedded) lists to produce a vector.

# The linkedin and facebook lists have already been created for you
linkedin <- list(16, 9, 13, 5, 2, 17, 14)
facebook <- list(17, 7, 5, 16, 8, 13, 14)

# Convert linkedin and facebook to a vector: li_vec and fb_vec
li_vec <- unlist(linkedin)
fb_vec <- unlist(facebook)

# Append fb_vec to li_vec: social_vec
social_vec <- append(li_vec, fb_vec)

# Sort social_vec
rev(sort(social_vec))

# Fix me - had to switch the two functions into the correct order
rep(seq(1, 7, by = 2), times = 7)

# Create first sequence: seq1
seq1 <- seq(1, 500, by = 3)

# Create second sequence: seq2
seq2 <- seq(1200, 900, by = -7)

# Calculate total sum of the sequences
sum(append(seq1, seq2))


#' Function to return the magnificent seven statistics for a given data series
#' @param x A dataframe containing a vector of date values in the first column and vector of numeric flow values in the second column.
#' @param yearType A charcter of either "water" or "calendar" indicating whether to use water years or calendar years, respectively.
#' @param digits A numeric. Number of digits to round indice values
#' @return data.frame of calculated statistics
#' @details This is a function to compute the 7 statistics of daily streamflow
#' used by Archfield et al., under revision (June 2013).
#' @importFrom lubridate month
#' @importFrom lubridate year
#' @importFrom lmom .samlmu
#' @export
#' @examples
#' x<-sampleData[c("date","discharge")]
#' magSeven <- calc_magnifSeven(x)
calc_magnifSeven<-function(x,yearType = "water",digits=3)  {

        #Check data inputs
        x <- validate_data(x,yearType = yearType)

        #calculate some stuff for use later
        x$month_val <- lubridate::month(x$date)

        #Compute L-moment ratios for time series so consistent in function
        complmom <- lmom::.samlmu(x$discharge)
        complmom[2] = complmom[2] / complmom[1]
        complmom = round(complmom, digits=2)
        lam1<-complmom[1]
        tau2<-complmom[2]
        tau3<-complmom[3]
        tau4<-complmom[4]

        #Compute AR(1) correlation coefficienct
        calc_ar1v<-calc_ar1(x,yearType = yearType,digits=digits)

        get_seasonality_vars <- get_seasonality(x, yearType = yearType)
        amplitude<-get_seasonality_vars[1]
        phase<-get_seasonality_vars[2]

        #Combine all indices into 1 dataframe and return
        magnif7 <- data.frame(indice = c("lam1","tau2","tau3","tau4","ar1","amplitude","phase"),
                            statistic = c(lam1,tau2,tau3,tau4,calc_ar1v,amplitude,phase),
                            stringsAsFactors = F)

        magnif7$statistic <- round(magnif7$statistic,digits=digits)

        return(magnif7)
}


# Function definitions for the normal-inverse-gamma distribution.
# The parameters of the distribution (mu, lambda, alpha, beta) are as defined here:
# https://en.wikipedia.org/wiki/Normal-inverse-gamma_distribution

# NOTE: The functions below require the function definitions in invgamma.r

dnorminvgamma <- function(x, sigma2, mu, lambda, alpha, beta) {
    # The pdf of the normal-inverse-gamma distribution at x (mean) and sigma2 (variance).
    return(dnorm(x, mu, sqrt(sigma2 / lambda)) * dinvgamma(sigma2, alpha, beta));
}

rnorminvgamma <- function(n, mu, lambda, alpha, beta) {
    # Draw n samples from the normal-inverse-gamma distribution.
    # Returns a matrix where each column contains a (x, sigma2) sample.
    sigma2 = rinvgamma(n, alpha, beta);  # Sample sigma^2 from the inverse-gamma
    x = rnorm(n, mu, sqrt(sigma2 / lambda));  # Sample x from the normal
    return(t(matrix(c(x, sigma2), nrow=n, ncol=2)));
}


#' winddir
#'
#' @description Calculate meteorological wind direction from cartesian components u and v.
#'
#' @param u numeric U zonal component (m/s) .
#' @param v numeric V meridian component (m/s).
#' @return wind direction provenience
#' @author  Istituto per la Bioeconomia CNR Firenze Italy  Alfonso Crisci \email{alfonso.crisci@@ibe.cnr.it}
#' @keywords Meteorological Wind direction
#'
#'
#' @export

winddir <- function(u, v) {
                    (180 / pi) * atan(u/v) + ifelse(v>0,180,ifelse(u>0,360,0))
}


#!/usr/bin/Rscript
# Copyright © 2016 Martin Ueding <dev@martin-ueding.de>
# Licensed under the MIT license.

iterapply = function(start, func, length) {
    result = numeric(length)
    result[1] = start
    for (i in 2:length) {
        result[i] = func(result[i - 1])
    }
    return(result)
}

get_next_x = function(x, alpha) {
    epsilon = runif(1)
    return (alpha * x + (1 - alpha) * epsilon)
}

generate_series = function(alpha) {
    return (iterapply(0, function(x) { return (get_next_x(x, alpha)) }, 100000))
}

xs = generate_series(0.1)
hist(xs, freq=FALSE)

xs = generate_series(0.3)
hist(xs, freq=FALSE)

xs = generate_series(0.7)
hist(xs, freq=FALSE)

xs = generate_series(0.9)
hist(xs, freq=FALSE)


##' @title
##' Regression Metrics Parameters
##'
##' @description
##' Documentation for shared parameters of functions that compute regression
##' metrics.
##'
##' @param actual \code{[numeric]} The ground truth numeric vector.
##' @param predicted \code{[numeric]} The predicted numeric vector, where each
##'     element in the vector is a prediction of the corresponding elements in
##'     \code{actual}.
##' @name regression_params
##' @include helper-functions.r
NULL

##' @title
##' Explained Variance
##'
##'
##' @description
##'
##' \code{mtr_explained_variance} computes explained variance, also known as
##' explained variation, which is interpreted as the percentage of variation in
##' one numeric vector explained by another. The best possible score is 1.0,
##' lower values are worse.
##'
##' @inheritParams regression_params
##' @importFrom stats var
##' @seealso \code{\link{mtr_r2}}
##' @return A numeric scalar output
##' @author An Chu
##' @examples
##'
##' act <- c(3, -0.5, 2, 7)
##' pred <- c(2.5, 0.0, 2, 8)
##' mtr_explained_variance(act, pred)
##'
##' act <- c(1.1, 1.9, 3.0, 4.4, 5.0, 5.6)
##' pred <- c(0.9, 1.8, 2.5, 4.5, 5.0, 6.2)
##' mtr_explained_variance(act, pred)
##'
##' @export
mtr_explained_variance <- function(actual, predicted) {

    check_equal_length(actual, predicted)

    exp_var <- 1 - (var(actual - predicted) / var(actual))
    exp_var
}

##' @title
##' Max Error
##'
##'
##' @description
##'
##' \code{mtr_max_error} computes the maximum residual error, a metric that
##' captures the worst error between the predicted value and the true value.
##'
##' @inheritParams regression_params
##' @return A numeric scalar output
##' @author An Chu
##' @examples
##'
##' act <- c(3, 2, 7, 1)
##' pred <- c(9, 2, 7, 1)
##' mtr_max_error(act, pred)
##'
##'
##' @export
mtr_max_error <- function(actual, predicted) {

    check_equal_length(actual, predicted)
    me <- max(abs(actual - predicted), na.rm = TRUE)
    me
}

##' @title
##' Mean Absolute Error
##'
##'
##' @description
##'
##' \code{mtr_mean_absolute_error} is a measure of difference between the
##' predicted value and the true value.
##'
##'
##'
##' @inheritParams regression_params
##' @return A numeric scalar output
##' @author An Chu
##' @name mae
##' @examples
##'
##' act <- c(3, -0.5, 2, 7)
##' pred <- c(2.5, 0.0, 2, 8)
##' mtr_mean_absolute_error(act, pred)
##' mtr_mae(act, pred)
##'
##'
##' @export
mtr_mean_absolute_error <- function(actual, predicted) {

    check_equal_length(actual, predicted)
    mae <- mean(abs(actual - predicted), na.rm = TRUE)
    mae
}

##' @export
##' @rdname mae
mtr_mae <- mtr_mean_absolute_error

##' @title
##' Mean Squared Error
##'
##'
##'
##' @description test
##'
##'
##'
##'
##' @inheritParams regression_params
##' @return A numeric scalar output
##' @author An Chu
##' @name mse
##' @export
##'
##'
##'
##' @export
##'
##'
##'
##'
##' @export
mtr_mean_squared_error <- function(actual, predicted) {

    check_equal_length(actual, predicted)
    mse <- mean((actual - predicted)^2, na.rm = TRUE)
    mse
}

##' @export
##' @rdname mse
mtr_mse <- mtr_mean_squared_error

##' @title
##' Root Mean Squared Error Function
##'
##'
##' @description test
##'
##'
##'
##'
##' @inheritParams regression_params
##' @return A numeric scalar output
##' @author An Chu
##' @examples
##'
##' act <- c(3, -0.5, 2, 7)
##' pred <- c(2.5, 0.0, 2, 8)
##' mtr_mean_squared_error(act, pred)
##'
##'
##' @export
mtr_root_mean_squared_error <- function(actual, predicted) {
    sqrt(mtr_mean_squared_error(actual, predicted))
}

##' @title
##' Mean Squared Log Error
##'
##'
##'
##' @description test
##'
##'
##'
##'
##'
##' @inheritParams regression_params
##' @return A numeric scalar output
##' @name msle
##' @author An Chu
##' @examples
##'
##' act <- c(3, 5, 2.5, 7)
##' pred <- c(2.5, 5, 4, 8)
##' mtr_mean_squared_log_error(act, pred)
##'
##'
##' @export
mtr_mean_squared_log_error <- function(actual, predicted) {

    check_equal_length(actual, predicted)
    msle <- mtr_mean_squared_error(log1p(actual), log1p(predicted))
    msle
}

##' @export
##' @rdname msle
mtr_msle <- mtr_mean_squared_log_error

##' @title
##' Median Absolute Error
##'
##'
##'
##' @description test
##'
##'
##' @details test
##'
##'
##'
##' @inheritParams regression_params
##' @importFrom stats median
##' @return A numeric scalar output
##' @name mdae
##' @author An Chu
##' @examples
##'
##' act <- c(3, -0.5, 2, 7)
##' pred <- c(2.5, 0.0, 2, 8)
##' mtr_median_absolute_error(act, pred)
##'
##'
##' @export
mtr_median_absolute_error <- function(actual, predicted) {

    check_equal_length(actual, predicted)
    mdae <- median(abs(actual - predicted), na.rm = TRUE)
    mdae
}

##' @export
##' @rdname mdae
mtr_mdae <- mtr_median_absolute_error

##' @title R2 Score
##'
##'
##'
##' @description test
##'
##'
##'
##'
##' @inheritParams regression_params
##' @return A numeric scalar output
##' @author An Chu
##' @examples
##'
##' act <- c(3, -0.5, 2, 7)
##' pred <- c(2.5, 0.0, 2, 8)
##' mtr_r2(act, pred)
##'
##'
##' @export
mtr_r2 <- function(actual, predicted) {

    check_equal_length(actual, predicted)

    if (length(predicted) < 2) {
        warning("R^2 is not applicable for less than two instances", call. = FALSE)
        return(NA_real_)
    }

    numerator <- sum((actual - predicted) ^ 2)
    denominator <- sum((actual - mean(actual)) ^ 2)

    zero_numerator <- numerator == 0
    zero_denominator <- denominator == 0

    if (zero_numerator || zero_denominator) return(0)

    r2 <- 1 - numerator / denominator
    r2
}