dataset = read.csv('2003 .csv')

# Taking care of missing data
#jan
dataset$Jan = ifelse(is.na(dataset$Jan),
                     ave(dataset$Jan, FUN = function(x) mean(x, na.rm = TRUE)),
                     dataset$Jan)
#feb
dataset$Feb = ifelse(is.na(dataset$Feb),
                     ave(dataset$Feb, FUN = function(x) mean(x, na.rm = TRUE)),
                     dataset$Feb)
#march
dataset$Mar = ifelse(is.na(dataset$Mar),
                     ave(dataset$Mar, FUN = function(x) mean(x, na.rm = TRUE)),
                     dataset$Mar)
#April
dataset$Apr = ifelse(is.na(dataset$Apr),
                     ave(dataset$Apr, FUN = function(x) mean(x, na.rm = TRUE)),
                     dataset$Apr)
#May
dataset$May = ifelse(is.na(dataset$May),
                     ave(dataset$May, FUN = function(x) mean(x, na.rm = TRUE)),
                     dataset$May)
#June
dataset$Jun = ifelse(is.na(dataset$Jun),
                     ave(dataset$Jun, FUN = function(x) mean(x, na.rm = TRUE)),
                     dataset$Jun)
#July
dataset$Jul = ifelse(is.na(dataset$Jul),
                     ave(dataset$Jul, FUN = function(x) mean(x, na.rm = TRUE)),
                     dataset$Jul)
#August
dataset$Aug = ifelse(is.na(dataset$Aug),
                     ave(dataset$Aug, FUN = function(x) mean(x, na.rm = TRUE)),
                     dataset$Aug)
#September
dataset$Sep = ifelse(is.na(dataset$Sep),
                     ave(dataset$Sep, FUN = function(x) mean(x, na.rm = TRUE)),
                     dataset$Sep)
#October
dataset$Oct = ifelse(is.na(dataset$Oct),
                     ave(dataset$Oct, FUN = function(x) mean(x, na.rm = TRUE)),
                     dataset$Oct)
#November
dataset$Nov = ifelse(is.na(dataset$Nov),
                     ave(dataset$Nov, FUN = function(x) mean(x, na.rm = TRUE)),
                     dataset$Nov)
#December
dataset$Dec = ifelse(is.na(dataset$Dec),
                     ave(dataset$Dec, FUN = function(x) mean(x, na.rm = TRUE)),
                     dataset$Dec)

#saveing the file
write.csv(dataset,'m2003.csv')

#finding missing data
is.na(dataset)
sapply(dataset, function(dataset) sum(is.na(dataset)))


# install.packages("changepoint")
library(dplyr)
library(purrr)
library(mgcv)
library(lubridate)
library(ggplot2)
library(changepoint)
library(stringr)

pdf_dir = "DATA/changepoint/"

theme_pew = function(base_size = 12, base_family = "") {
  # ggplot theme

  # Starts with theme_grey and then modify some parts
  theme_grey(base_size = base_size, base_family = base_family) %+replace%
    theme(
      axis.line = element_line(colour = "black"),
      axis.text         = element_text(size = rel(0.8)),
      axis.ticks        = element_line(colour = "black"),
      legend.key        = element_rect(colour = "grey80"),
      panel.background = element_blank(),
      panel.border      = element_rect(fill = NA, colour = "grey50"),
      panel.grid.major = element_blank(),
      panel.grid.minor = element_blank(),
      axis.line.x = element_line(color="black", size = .3),
      axis.line.y = element_line(color="black", size = .3),
      strip.background  = element_rect(fill = "grey80", colour = "grey50", size = 0.2)
    )
}

cp_binseg = function(df_imputed_values, df_means, df_smoothed_values, region, category, Q_val=10, max_y=-1, do_plotting=TRUE, bin_width=.1) {
  # Runs a series of binary segmentation changepoint models
  #   and saves the resulting charts to pdf
  # Args:
  #   df_imputed_values: Long-format dataframe of every imputed value
  #   df_means: Dataframe with each per-period mean of imputed values
  #   df_smoothed_values: Dataframe with smoothed values
  #   region: String name of region being plotted
  #   category: String name of category being plotted
  #   Q_val: Maximum number of changepoints to search for, passed to cpt.mean().
  #   max_y: integer to standardize y-axis. Defaults to -1, in which no re-scaling is done.
  #   do_plotting: Should PDF plots be produced or not?
  #   bin.width: Bin width for the histogram produced as a side effect of this function

  # Set up file
  dir.create(pdf_dir)
  pdf_path = paste0(pdf_dir, "changepoints_",region,"-", category,".pdf")
  pdf(file=pdf_path)

  # Run model and put results in a list
  binseg_est = cpt.mean(df_means$imputed_mean, method="BinSeg", Q=Q_val, minseglen = 3)

  # some models will identify the 1st and last periods, but this doesn't. We will need this for drawing lines.
  binseg_results = c(0, cpts(binseg_est), nrow(df_means))
  binseg_result_pairs = map2(binseg_results, lead(binseg_results, 1), ~c(.x, .y))
  binseg_result_pairs = binseg_result_pairs[-length(binseg_result_pairs)]
  # Extract information for charting
  # Setup
  binseg_range_means = NULL
  binseg_range_maxes = NULL
  prev_cps = NULL
  curr_cps = NULL
  prev_cps_dates = NULL
  curr_cps_dates = NULL
  range_max_dates = NULL
  i = 0
  # cycle through pairs of each element. Takes the mean, max, etc. of each range.
  # e.g. in a model with 10 periods, each row of the resulting dataframe will be period 1 to 2, 2 to 3, 3 to 4, etc.
  for (pair in binseg_result_pairs)
  {
    i = i + 1
    prev_cp = pair[1] + 1
    curr_cp = pair[2]

    # take the mean of this range. Remember to set curr_cp - 1 - don't want to include changepoint in this range.
    curr_mean = mean(df_means[prev_cp:curr_cp-1, "imputed_mean"]$imputed_mean)
    curr_max = max(df_means[prev_cp:curr_cp-1,"imputed_mean"]$imputed_mean)

    binseg_range_means[i] = curr_mean
    binseg_range_maxes[i] = curr_max

    prev_cps_dates[i] = df_means[prev_cp, ]$period_date
    curr_cps_dates[i] = df_means[curr_cp, ]$period_date
    range_max_dates[i] = df_means[which(df_means$imputed_mean==curr_max), ]$period_date
    prev_cps[i] = prev_cp
    curr_cps[i] = curr_cp
  }
  binseg_range_max_deltas = map2(lag(binseg_range_maxes, 1), binseg_range_maxes, ~abs(.y - .x)) %>% unlist()
  binseg_range_max_delta_perc = binseg_range_max_deltas / lag(binseg_range_maxes, 1)
  mean_delta = mean(binseg_range_max_deltas, na.rm = TRUE)
  sd_delta = sd(binseg_range_max_deltas, na.rm = TRUE)

  # set data frame
  binseg_results = data.frame(prev = prev_cps,
                              curr = curr_cps,
                              prev_date = as.Date(prev_cps_dates),
                              curr_date = as.Date(curr_cps_dates),
                              means = binseg_range_means,
                              max_date = as.Date(range_max_dates),
                              maxes = binseg_range_maxes,
                              max_deltas = binseg_range_max_deltas,
                              max_delta_perc = binseg_range_max_delta_perc)
  print(binseg_results)
  write.csv(binseg_results, paste("DATA/changepoint/changepoints_",region,"-", category,".csv", sep=""))

  # and plot
  if (do_plotting) {
    plt_title = paste(region, category, "BinSeg: ", Q_val)
    binseg_plt = ggplot() +
      ggtitle(plt_title) +
      scale_x_date(date_breaks="4 month", date_labels ="%m/%y") + labs(x="Period", y="Proportion of Attention") + theme(axis.text.x = element_text(angle=90, hjust=1)) +
      theme_pew() +
      theme(legend.position = "none") +
      geom_point(data=df_imputed_values, aes(y=imputed_value, x=period_date), color="#CCCCCC", size=.05) +
      geom_line(data=df_means, aes(y=imputed_mean, x=period_date), color="#6600CC", alpha=.4) +
      geom_line(data=df_smoothed_values, aes(y=smoothed, x=period_date), color="#990033") +
      geom_segment(data=binseg_results, aes(x=prev_date, xend=curr_date, y=means, yend=means), color="blue", size=.5) +
      geom_text(data=binseg_results, aes(x=prev_date, y=means+200, label=round(binseg_range_max_delta_perc, 3)), size=2)
    if (max_y > -1) {
      binseg_plt = binseg_plt + scale_y_continuous(limits=c(0,max_y))

      # Save histogram
      hist_plt = ggplot(data=binseg_results, aes(x=max_delta_perc)) + geom_histogram(binwidth = bin_width) +
        ggtitle(plt_title) +
        labs(x="Diff in Max", y="Count")
    }
    print(binseg_plt)
    print(hist_plt)
  }
  dev.off()

}

run_gam = function(df, k_val=50, region, category, max_y, seed = 20180910) {
  # Runs gam model, calculating smoothed data.
  # In turn, runs changepoint model.
  # Args:
  #   df: Long-format dataframe of imputed values (col: imputed_value)
  #   k_val: gam model parameter that specifies number of curves in model. Lower = smoother.
  #   region: Name of region being run. Used for charts.
  #   category: Name of category being run. Used for charts.
  #   max_y: Maximum value of y, if standardizing.
  #   seed: Seed for sampling 50 samples for each period if there are more than 50

  # Verify some basic conversions
  df$num_period = as.numeric(df$period)
  df$period_date = ymd(as.character(df$period))

  # if there are more than 50, take a random subset to get to 50
  df_samples = df %>% group_by(sample) %>% summarize(cnt = n())
  set.seed(seed)
  if (nrow(df_samples) > 50) {
    df = subset(df, sample %in% sample_n(df_samples, 50)$sample)
  }

  # calculate means
  df_means = df %>%
    group_by(period_date) %>%
    summarize(imputed_mean = mean(imputed_value))

  # run gam
  m = gam(imputed_value~s(num_period, k=k_val),  data=df)

  # get predicted values
  df_pred = df %>%
    select(period_date, num_period) %>%
    distinct() %>%
    as_tibble()
  df_pred$smoothed = predict(m, newdata = df_pred)

  cp_binseg(df, df_means, df_pred, region, category, max_y=max_y)
  df_pred$smoothed
}

run_plots = function(input_path, region) {
  # Creates all smoothed, changepoint filled plots per category for the specified region.
  # Args:
  #   input_path: sub-directory where data are stored
  #   region: Name of region being studied. This value is used for chart titles and file names.

  files = list.files(input_path, pattern='*imputed_samples.csv', full.names=TRUE)
  dfs = vector("list", length(files))
  i = 1
  # Need to determine the maximum y value so we can plot everything on the same y-scale
  cross_cat_max = 0
  for (f in files) {
    df = read.csv(f)
    curr_max = max(df$imputed_value)
    cross_cat_max = max(cross_cat_max, curr_max)
    dfs[[i]] = df
    i = i+1
  }

  # setup for run
  # Add some additional space at the top so we're not right at the top
  cross_cat_max = cross_cat_max + 100
  df_results = dfs[[1]] %>% group_by(period) %>% summarize()
  for (i in 1:length(dfs)) {
    category = str_match(files[i],'-([A-z &]+)_imputed')[1,2]
    print(paste("Running", category))
    print(head(dfs[[i]]$imputed_value, 60))
    smoothed_vals = run_gam(dfs[[i]], 50, region, category, cross_cat_max)
    df_results[category] = smoothed_vals
  }

  # save imputed data
  dir.create("DATA/smoothed/")
  csv_file = paste("DATA/smoothed/smoothed_",region,'.csv', sep="")
  print(paste("Saving to:", csv_file))
  write.csv(df_results, csv_file)
}

setwd("~/repos/flint_water/Search")
all_results = NULL
run_plots("DATA/513/combined", "Flint")
run_plots("DATA/US/combined", "National")
run_plots("DATA/US-MI/combined", "Michigan")


'https://www-bcf.usc.edu/~gareth/ISL/'
# Free machine learning book

Machine learning is a method of data analysis
# Made to automate analytical model building
# Uses algorithms to learn from data
# Finds hidden insights without being told to.

Process of machine learning
# Data acquision
# Cleaning data, model training & building
# Cleaning data, test data
# Model training repeat
# Model deployment

Supervised learning
# Algorithms are trained using labeled examples
# Input is where the output is know
# Recives inputs along with correct outputs
# Compares these to find errors
# > Modifies the model accordingly

Unsupervised learning
# Takes no historical labels
# Does not know the right answer, figures it out
# Explores data to find structure
# Uses for example, learnest neightbor mapping
# k-means clustering or single value decomposition

Reinforcement learning
# Used in robotics, gaming and navigation
# Discovers through trial and error
# Greatest reward gives highest "points"
# 3 components (agent: learner / decision maker)
# (environment: everything it interacts with)
# (actions: everything it does)


year = as.integer(readline(prompt="Enter a year: "))
if((year %% 4) == 0) {
if((year %% 100) == 0) {
if((year %% 400) == 0) {
print(paste(year,"is a leap year"))
} else {
print(paste(year,"is not a leap year"))
}
} else {
print(paste(year,"is a leap year"))
}
} else {
print(paste(year,"is not a leap year"))
}


#' Generate prior distributions for k using stream geometry
#'
#' @details Generates means and standard deviations for half-normal priors for k600. This
#' function uses the 7 equations from Raymond et al 2012. Which equation to use is a user
#' choice, though there are some recommendations from Raymond to guide the choice (see below,
#' and see Raymond et al 2012).
#'
#' Rayment et al provide standard deviations for the parameters, but do NOT provide information
#' on correlations among parameters; therefore this function treats them as independent (which
#' will generally produce larger prior standard deviations). The standard deviation is chosen
#' by simulating across independent parameter combinations.
#'
#' Slope and velocity are required for all equations. Discharge and depth are required for
#' equations 6 & 7 (discharge) and 1, 2, and 7 (depth); for equations 3-5 they can safely be
#' left set to NA.
#'
#' Guidelines for k:
#' Best for small streams:
#' includes depth, more preditive, but less general, not in accordance with theory
#' 		eq 1, 2
#'
#' More general (includes only slope & velocity), but maybe less precise
#' 		eq 3-5
#'
#' Equation 6 also includes discharge, predictability is lower, an alt to 3-5
#' Equation 7 includes depth and discharge; theoretically problematic, but
#' 		prediction might be better for small streams
#'
#' @param slope Stream slope (unitless; meters of height/meters of length)
#' @param velocity In meters/second
#' @param discharge In m^3/sec
#' @param depth In meters
#' @param eqn Which equation(s) to use
#' @param nsim Number of simulations used for the standard deviation
#'
#' @return If a single equations is given, a 2-column matrix giving the mean and standard
#'   deviation for k for each value in slope, velocity, etc. Otherwise a list of such matrices,
#'   one for each equation in eqn. Units for k are meters/day
#' @references Raymond, P.A. et al. (2012). Scaling the gas transfer velocity and hydraulic
#' 		 geometry in streams and small rivers. Limnol. Oceanogr., 2, 41–53.
#' @examples
#' sl = 0.05
#' v = 0.5
#' q = 1
#' d = 0.5
#' eq1 = k_prior(sl, v, q, d, eqn = 1, nsim=3) ## normally run thousands of sims
#' @export
k_prior = function(slope, velocity, depth = NA, discharge = NA, eqn = 1:7, nsim = 5000) {
	if(!all(eqn %in% 1:7))
		stop("Unknown equation; ensure all values in eqn are in 1:7")
	if(length(eqn) > 1) {
		lapply(eqn, function(e) k_prior(slope, velocity, depth, discharge, e, nsim))
	} else {
		params = .k_parameters()
		simpars = .k_generate_pars(params$pars[[eqn]], params$pars_se[[eqn]], 5000)
		sds = .k_sd_sim(slope, velocity, depth, discharge, simpars, eqn)
		means = .k_compute(slope, velocity, depth, discharge, params$pars[[eqn]], eqn)
		cbind(mean = means, stdev = sds)
	}
}

#' generate parameter sets (assuming independence) for k sims
#' @keywords internal
.k_generate_pars = function(par, se, n) {
	mapply(function(mu, stdev, N) rnorm(N, mu, stdev), par, se, n)
}

#' generate standard dev of k for a given set of stream variables
#' @keywords internal
.k_sd_sim = function(S, V, D, Q, pars, eqn) {
	getsd = function(S, V, D, Q, p, eqn) sd(apply(p, 1, function(x)
		.k_compute(S, V, D, Q, x, eqn)))
	if(requireNamespace("parallel")) {
		parallel::mcmapply(FUN = getsd, S = S, V = V, D = D,
			Q = Q, MoreArgs = list(p = pars, eqn = eqn))
	} else {
		mapply(FUN = getsd, S = S, V = V, D = D,
			Q = Q, MoreArgs = list(p = pars, eqn = eqn))
	}
}

# compute k
#' @keywords internal
.k_compute = function(S, V, D, Q, pars, eq) {
	eq = paste0('eq', eq)
	# magic number is gravitational acceleration
	fr = V / sqrt(9.806*D)
	switch(eq,
		eq1 = (V*S)^(pars[1]) * D^(pars[2]) * pars[3],
		eq2 = pars[1] * (1 - pars[2] * fr^2) * (V*S)^(pars[3]) * D^(pars[4]),
		eq3 = pars[1] * S^pars[2] * V^pars[3],
		eq4 = (V*S)^pars[1] * pars[2],
		eq5 = V*S*pars[1] + pars[2],
		eq6 = pars[1] * (V*S)^(pars[2]) * Q^pars[3],
		eq7 = pars[1] * (V*S)^(pars[2]) * Q^pars[3] * D^pars[4]
	)
}

#' Constant for k parameters
#' @keywords internal
.k_parameters = function() {
	## parameters from Raymond
	pars = list(
		eq1 = c(0.89, 0.54, 5037),
		eq2 = c(5937, 2.54, 0.89, 0.58),
		eq3 = c(1162, 0.77, 0.85),
		eq4 = c(0.76, 951.5),
		eq5 = c(2841, 2.02),
		eq6 = c(929, 0.75, 0.011),
		eq7 = c(4725, 0.86, -0.14, 0.66))
	pars_se = list(
		eq1 = c(0.020, 0.030, 604),
		eq2 = c(606, 0.223, 0.017, 0.027),
		eq3 = c(192, 0.028, 0.045),
		eq4 = c(0.027, 144),
		eq5 = c(107, 0.209),
		eq6 = c(141, 0.027, 0.016),
		eq7 = c(445, 0.016, 0.012, 0.029))
	list(pars = pars, pars_se = pars_se)
}


#Adam Burns - 2/10/2015
#From Burns et al. Contribution of neutral processes to the assembly of the gut microbial communities changes over host development
#Fits the neutral model from Sloan et al. 2006 to an OTU table and returns several fitting statistics. Alternatively, will return predicted occurrence frequencies for each OTU based on their abundance in the metacommunity when stats=FALSE.
#spp: A community table for communities of interest with local communities/samples as rows and taxa as columns. All samples must be rarefied to the same depth.
#pool: A community table for defining source community (optional; Default=NULL).
#taxon: A table listing the taxonomic calls for each otu, with OTU ids as row names and taxonomic classifications as columns.
#If stats=TRUE the function will return fitting statistics.
#If stats=FALSE the function will return a table of observed and predicted values for each otu.

sncm.fit <- function(spp, pool=NULL, stats=TRUE, taxon=NULL){
	require(minpack.lm)
	require(Hmisc)
	require(stats4)

	options(warn=-1)

	#Calculate the number of individuals per community
	N <- mean(apply(spp, 1, sum))

	#Calculate the average relative abundance of each taxa across communities
	if(is.null(pool)){
		p.m <- apply(spp, 2, mean)
		p.m <- p.m[p.m != 0]
		p <- p.m/N
	} else {
		p.m <- apply(pool, 2, mean)
		p.m <- p.m[p.m != 0]
		p <- p.m/N
	}

	#Calculate the occurrence frequency of each taxa across communities
	spp.bi <- 1*(spp>0)
	freq <- apply(spp.bi, 2, mean)
	freq <- freq[freq != 0]

	#Combine
	C <- merge(p, freq, by=0)
	C <- C[order(C[,2]),]
	C <- as.data.frame(C)
	C.0 <- C[!(apply(C, 1, function(y) any(y == 0))),] #Removes rows with any zero (absent in either source pool or local communities)
	p <- C.0[,2]
	freq <- C.0[,3]
	names(p) <- C.0[,1]
	names(freq) <- C.0[,1]

	#Calculate the limit of detection
	d = 1/N

	##Fit model parameter m (or Nm) using Non-linear least squares (NLS)
	m.fit <- nlsLM(freq ~ pbeta(d, N*m*p, N*m*(1-p), lower.tail=FALSE), start=list(m=0.1))
	m.ci <- confint(m.fit, 'm', level=0.95)

	##Fit neutral model parameter m (or Nm) using Maximum likelihood estimation (MLE)
	sncm.LL <- function(m, sigma){
		R = freq - pbeta(d, N*m*p, N*m*(1-p), lower.tail=FALSE)
		R = dnorm(R, 0, sigma)
		-sum(log(R))
	}
	m.mle <- mle(sncm.LL, start=list(m=0.1, sigma=0.1), nobs=length(p))

	##Calculate Akaike's Information Criterion (AIC)
	aic.fit <- AIC(m.mle, k=2)
	bic.fit <- BIC(m.mle)

	##Calculate goodness-of-fit (R-squared and Root Mean Squared Error)
	freq.pred <- pbeta(d, N*coef(m.fit)*p, N*coef(m.fit)*(1-p), lower.tail=FALSE)
	Rsqr <- 1 - (sum((freq - freq.pred)^2))/(sum((freq - mean(freq))^2))
	RMSE <- sqrt(sum((freq-freq.pred)^2)/(length(freq)-1))

	pred.ci <- binconf(freq.pred*nrow(spp), nrow(spp), alpha=0.05, method="wilson", return.df=TRUE)

	##Calculate AIC for binomial model
	bino.LL <- function(mu, sigma){
		R = freq - pbinom(d, N, p, lower.tail=FALSE)
		R = dnorm(R, mu, sigma)
		-sum(log(R))
	}
	bino.mle <- mle(bino.LL, start=list(mu=0, sigma=0.1), nobs=length(p))

	aic.bino <- AIC(bino.mle, k=2)
	bic.bino <- BIC(bino.mle)

	##Goodness of fit for binomial model
	bino.pred <- pbinom(d, N, p, lower.tail=FALSE)
	Rsqr.bino <- 1 - (sum((freq - bino.pred)^2))/(sum((freq - mean(freq))^2))
	RMSE.bino <- sqrt(sum((freq - bino.pred)^2)/(length(freq) - 1))

	bino.pred.ci <- binconf(bino.pred*nrow(spp), nrow(spp), alpha=0.05, method="wilson", return.df=TRUE)

	##Calculate AIC for Poisson model
	pois.LL <- function(mu, sigma){
		R = freq - ppois(d, N*p, lower.tail=FALSE)
		R = dnorm(R, mu, sigma)
		-sum(log(R))
	}
	pois.mle <- mle(pois.LL, start=list(mu=0, sigma=0.1), nobs=length(p))

	aic.pois <- AIC(pois.mle, k=2)
	bic.pois <- BIC(pois.mle)

	##Goodness of fit for Poisson model
	pois.pred <- ppois(d, N*p, lower.tail=FALSE)
	Rsqr.pois <- 1 - (sum((freq - pois.pred)^2))/(sum((freq - mean(freq))^2))
	RMSE.pois <- sqrt(sum((freq - pois.pred)^2)/(length(freq) - 1))

	pois.pred.ci <- binconf(pois.pred*nrow(spp), nrow(spp), alpha=0.05, method="wilson", return.df=TRUE)

	##Results
	if(stats==TRUE){
		fitstats <- data.frame(m=numeric(), m.ci=numeric(), m.mle=numeric(), maxLL=numeric(), binoLL=numeric(), poisLL=numeric(), Rsqr=numeric(), Rsqr.bino=numeric(), Rsqr.pois=numeric(), RMSE=numeric(), RMSE.bino=numeric(), RMSE.pois=numeric(), AIC=numeric(), BIC=numeric(), AIC.bino=numeric(), BIC.bino=numeric(), AIC.pois=numeric(), BIC.pois=numeric(), N=numeric(), Samples=numeric(), Richness=numeric(), Detect=numeric())
		fitstats[1,] <- c(coef(m.fit), coef(m.fit)-m.ci[1], m.mle@coef['m'], m.mle@details$value, bino.mle@details$value, pois.mle@details$value, Rsqr, Rsqr.bino, Rsqr.pois, RMSE, RMSE.bino, RMSE.pois, aic.fit, bic.fit, aic.bino, bic.bino, aic.pois, bic.pois, N, nrow(spp), length(p), d)
		return(fitstats)
	} else {
		A <- cbind(p, freq, freq.pred, pred.ci[,2:3], bino.pred, bino.pred.ci[,2:3])
		A <- as.data.frame(A)
		colnames(A) <- c('p', 'freq', 'freq.pred', 'pred.lwr', 'pred.upr', 'bino.pred', 'bino.lwr', 'bino.upr')
		if(is.null(taxon)){
			B <- A[order(A[,1]),]
		} else {
			B <- merge(A, taxon, by=0, all=TRUE)
			row.names(B) <- B[,1]
			B <- B[,-1]
			B <- B[order(B[,1]),]
		}
		return(B)
	}
}


results <- c()
stdErr <- c()
sumHisto <- c()
numberOfSamples = length(data) - 11
for (i in 11:length(data)) {
  historyData <- data[1:i]
  sumHisto <- c(sumHisto, sum(historyData))
  fitDn <- tryCatch({nlsLM(historyData~a*pnorm(1:i, mean = m, sd = sd), start=list(m=10,sd=2,a=100))},
                    error = function(e) {print(e)})
  sdCur = as.list(coef(fitDn))$sd
  sdCurStdErr = summary(fitDn)$coefficients[1,1]
  print(sdCur)
  stdErr <- c(stdErr, sdCurStdErr)
  results <- c(results, sdCur)
}

plot(results, type = 'l')
points(stdErr)
sdMean <- weighted.mean(results, sumHisto * results / stdErr)
print('weightedSdMean')
print(sdMean)
abline(sdMean, 0)

invStdErrNorm <- normalize.vector(1/stdErr)

print('Var Std Err. Sd')
varStdErrSd <- var(abs(results - sdMean)*invStdErrNorm/length(stdErr))
print(varStdErrSd)


x2 <- seq(0,2*pi,len=100)

y2 <- sin(x2)

y4 <- cos(x2)

plot(y2)
plot(y4)

par(mfrow = c(1,2))
plot(y2,y4)

polygon(y2,y4,col='lightgreen')

plot(y2,y4, asp=1, type='n')
polygon(y2,y4,col='lightgreen')
#install.packages("GISTools", depend = T)

library(GISTools)

data(georgia)

class(georgia)

georgia@data

appling <- georgia.polys[[1]]

View(georgia@data)

plot.new()
plot(appling, asp=1, type='n', xlab="Easting", ylab="Northing")

polygon(appling, density=10, angle=145)

View(appling[[1]])
colours()

polygon(appling, col="blue")
polygon(appling, col=rgb(0,0.5,0.7,0.4))

# set the plot extent
plot(appling, asp=1, type='n', xlab="Easting", ylab="Northing")

# plot the points
points(x = runif(500,126,132)*10000,
       y = runif(500,103,108)*10000, pch=16, col='red')
# plot the polygon with a transparency factor

polygon(appling, col=rgb(0,0.5,0.7,0.4))

plot(c(-1.5,1.5),c(-1.5,1.5),asp=1, type='n')
# plot the green/blue rectangle
rect(-0.5,-0.5,0.5,0.5, border=NA, col=rgb(0,0.5,0.5,0.7))
# then the second one
rect(0,0,1,1, col=rgb(1,0.5,0.5,0.7))

data(meuse.grid)

mat = SpatialPixelsDataFrame(points = meuse.grid[c("x", "y")],
                             data = meuse.grid)
image(mat, "dist")

library(RColorBrewer)

greenpal <- brewer.pal(7,'Greens')

image(mat, "dist", col=greenpal)
library(ggplot2)
theme_bw()
theme_dark()
library(gridExtra)

appling

appling <- data.frame(appling)

colnames(appling) <- c("X", "Y")

#ggplot2

p1 <- qplot(X, Y, data = appling, geom = "polygon", asp = 1,
            colour = I("black"),
            fill=I(rgb(0,0.5,0.7,0.4))) +
  theme(axis.text=element_text(size=12),
        axis.title=element_text(size=20))
# create a data.frame to hold the points

p1

df <- data.frame(x = runif(500,126,132)*10000,
                 y = runif(500,103,108)*10000)

p2 <- ggplot(appling, aes(x = X, y= Y)) +
  geom_polygon(fill = I(rgb(0,0.5,0.7,0.4))) +
  geom_point(data = df, aes(x, y),col=I('red')) +
  coord_fixed() +
  theme(axis.text=element_text(size=12),
        axis.title=element_text(size=20))
p2

grid.arrange(p1, p2, ncol = 2)

#is.element("sf", installed.packages())

#install.packages("sf", dep = TRUE)
#help(sf)
#??sf
#library(GISTools)

data(newhaven)

ls()
class(breach)
class(appling)
class(Rooms)
class(roads)
head(data.frame(blocks))
head(blocks@data)

plot(blocks)

par(mar = c(0,0,0,0))
plot(roads, col="red")
plot(blocks, add = T)

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

library(sf)

vignette(package = "sf")
vignette("sf1", package = "sf")

# load the georgia data
data(georgia)

# conversion to sf
georgia_sf = st_as_sf(georgia)
class(georgia_sf)

View(georgia_sf)

View(georgia@data)

# all attributes
plot(georgia_sf)
# selected attribute
plot(georgia_sf[, 6])
# selected attributes
plot(georgia_sf[,c(4,5)])

georgia_sf[,c(4,5)]
georgia_sf

## sp SpatialPolygonDataFrame object
head(data.frame(georgia))
## sf polygon object
head(data.frame(georgia_sf))

#######3 --BLOCK --> Spatial frame

roads_sf <- st_as_sf(roads)
class(roads_sf)
r2 <- as(roads_sf, "Spatial")
class(r2)

##############
library(rgdal)

writeOGR(obj=georgia, dsn="./nam", layer="abc",
         driver="ESRI Shapefile", overwrite_layer=T)

new.georgia <- readOGR("test/georgia.shp")

class(new.georgia)

writeOGR(new.georgia, dsn = "./test", layer = "georgia",
         driver="ESRI Shapefile", overwrite_layer = T)

#st_read()
#st_write()

g2 <- st_read("test/georgia.shp")

st_write(g2, "test/georgia.shp", delete_layer = T)

st_write(g2, dsn = "test/georgia.shp", layer = "georgia.shp",
         driver = "ESRI Shapefile", delete_layer = T)

#mapping
rm(list=ls())

data(georgia)

georgia_sf <- st_as_sf(georgia)

##### PLOTING USING TMAP ---_ggpolot2

library(tmap)

qtm(georgia, fill = "red", style = "natural")

qtm(georgia_sf, fill="MedInc", text="Name", text.size=1,
    format="World_wide", style="classic",
    text.root=5, fill.title="Median Income")

# sf -->
# PostGIS   --> st_area

g <- st_union(georgia_sf)

## using tmap libary ggplot

tm_shape(georgia_sf) +
  tm_fill("tomato")

tm_shape(georgia_sf) +
  tm_fill("tomato") +
  tm_borders(lty = "dashed", col = "gold")

tm_shape(georgia_sf) +
  tm_fill("tomato") +
  tm_borders(lty = "dashed", col = "gold") +
  tm_style("natural", bg.color = "grey90")

tm_shape(georgia_sf) +
  tm_fill("tomato") +
  tm_borders(lty = "dashed", col = "gold") +
  tm_style("natural", bg.color = "grey90") +
  # now add the outline
  tm_shape(g) +
  tm_borders(lwd = 2)

tm_shape(georgia_sf) +
  tm_fill("tomato") +
  tm_borders(lty = "dashed", col = "gold") +
  tm_style("natural", bg.color = "grey90") +
  # now add the outline
  tm_shape(g) +
  tm_borders(lwd = 2) +
  tm_layout(title = "The State of Georgia",
            title.size = 1, title.position = c(0.55, "top"))

# 1st plot of georgia
t1 <- tm_shape(georgia_sf) +
  tm_fill("coral") +
  tm_borders() +
  tm_layout(bg.color = "grey85")

# 2nd plot of georgia2
t2 <- tm_shape(georgia2) +
  tm_fill("orange") +
  tm_borders() +
  # the asp paramter controls aspect
  # this is makes the 2nd plot align
  tm_layout(asp = 0.86,bg.color = "grey95")

library(grid)
# open a new plot page
grid.newpage()
# set up the layout
pushViewport(viewport(layout=grid.layout(1,2)))
# plot using the print command
print(t1, vp=viewport(layout.pos.col = 1, height = 5))
print(t2, vp=viewport(layout.pos.col = 2, height = 5))

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

data.frame(georgia_sf)[,13]

tm_shape(georgia_sf) +
  tm_fill("white") +
  tm_borders()+
  tm_text("Name", size = 0.3)+
  tm_layout(frame = FALSE)

######## ----
index <- c(81, 82, 83, 150, 62, 53, 21, 16, 124, 121, 17)
georgia_sf.sub <- georgia_sf[index,]

tm_shape(georgia_sf.sub) +
  tm_fill("gold1") +
  tm_borders("grey") +
  tm_text("Name", size = 1) +
  # add the outline
  tm_shape(g) +
  tm_borders(lwd = 2) +
  # specify some layout parameters
  tm_layout(frame = FALSE, title = "A subset of Georgia",
            title.size = 1.5, title.position = c(0., "bottom"))

# the 1st layer
tm_shape(georgia_sf) +
  tm_fill("white") +
  tm_borders("grey", lwd = 0.5) +
  # the 2nd layer
  tm_shape(g) +
  tm_borders(lwd = 2) +
  # the 3rd layer
  tm_shape(georgia_sf.sub) +
  tm_fill("lightblue") +
  tm_borders() +
  # specify some layout parameters
  tm_layout(frame = T, title = "Georgia with a subset of counties",
            title.size = 1, title.position = c(0.02, "bottom"))

##### plolty --> interactive plot with ggplot2

# library(OpenStreetMap)
# # define upper left, lower right corners
# georgia.sub <- georgia[index,]
#
#
# ul <- as.vector(cbind(bbox(georgia.sub)[2,2],
#                       bbox(georgia.sub)[1,1]))
# lr <- as.vector(cbind(bbox(georgia.sub)[2,1],
#                       bbox(georgia.sub)[1,2]))
# # download the map tile
# MyMap <- openmap(ul,lr)
# # now plot the layer and the backdrop
# par(mar = c(0,0,0,0))
# plot(MyMap, removeMargin=FALSE)
# plot(spTransform(georgia.sub, osm()), add = TRUE, lwd = 2)

# load the package

library(RgoogleMaps)

# convert the subset
shp <- SpatialPolygons2PolySet(georgia.sub)
# determine the extent of the subset
bb <- qbbox(lat = shp[,"Y"], lon = shp[,"X"])
# download map data and store it
MyMap <- GetMap.bbox(bb$lonR, bb$latR, destfile = "DC.jpg")
# now plot the layer and the backdrop
par(mar = c(0,0,0,0))
PlotPolysOnStaticMap(MyMap, shp, lwd=2,
                     col = rgb(0.25,0.25,0.25,0.025), add = F)

####
tmap_mode('view')

tm_shape(georgia_sf.sub) +
  tm_polygons(col = "#C6DBEF80" )

tmap_mode("plot")

# load package and data
library(GISTools)
data(newhaven)

proj4string(roads) <- proj4string(blocks)
# plot spatial data
tm_shape(blocks) +
  tm_borders() +
  tm_shape(roads) +
  tm_lines(col = "red") +
  # embellish the map
  tm_scale_bar(width = 0.22) +
  tm_compass(position = c(0.8, 0.07)) +
  tm_layout(frame = F, title = "New Haven, CT",
            title.size = 1.5,
            title.position = c(0.55, "top"),
            legend.outside = T)

# sf -->

# load package and data

pts_sf <- st_centroid(georgia_sf)
pts_sf

plot(pts_sf)

png(filename = "centroid.png", w = 5, h = 7, units = "in", res = 150)

tm_shape(georgia_sf) +
  tm_fill("olivedrab4") +
  tm_borders("grey", lwd = 1) +
  # the points layer
  tm_shape(pts_sf) +
  tm_bubbles("PctBlack", title.size = "% Black", col = "gold")

# clear workspace
rm(list = ls())
# load & list the data
data(newhaven)
ls()
# convert to sf
blocks_sf <- st_as_sf(blocks)
breach_sf <- st_as_sf(breach)
tracts_sf <- st_as_sf(tracts)
# have a look at the attributes and object class
summary(blocks_sf)
class(blocks_sf)
summary(breach_sf)
class(breach_sf)
summary(tracts_sf)
class(tracts_sf)

data.frame(blocks_sf)

head(data.frame(blocks_sf))
colnames(data.frame(blocks_sf))
names(blocks_sf)
colnames(blocks@data)
head(blocks@data)

data.frame(blocks_sf$P_VACANT)
blocks$P_VACANT

attach(data.frame(blocks_sf)) #attach() function in R Language is used to access the variables present in the data framework without calling the data frame.

hist(blocks$P_VACANT)

detach(data.frame(blocks_sf))

breach.dens = st_as_sf(kde.points(breach,lims=tracts)) #kde is to create kernel density surface
summary(breach.dens)

breach.dens
plot(breach.dens)
blocks_sf$RandVar <- rnorm(nrow(blocks_sf))

tmap_mode('plot')
tm_shape(blocks_sf) +
  tm_polygons("P_OWNEROCC")

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

tm_shape(blocks_sf) +
  tm_polygons("P_OWNEROCC", breaks=seq(0, 100, by=25))

tm_shape(blocks_sf) +
  tm_polygons("P_OWNEROCC", breaks=c(10, 40, 60, 90))

tm_shape(blocks_sf) +
  tm_polygons("P_OWNEROCC", title = "Owner Occ") +
  tm_layout(legend.title.size = 1,
            legend.text.size = 1,
            legend.position = c(0.1, 0.1))

display.brewer.all()
brewer.pal(5,'Blues')

tm_shape(blocks_sf) +
  tm_polygons("P_OWNEROCC", title = "Owner Occ", palette = "Reds") +
  tm_layout(legend.title.size = 1)

tm_shape(blocks_sf) +
  tm_fill("P_OWNEROCC", title = "Owner Occ", palette = "Blues") +
  tm_layout(legend.title.size = 1)

# with equal intervals: the tmap default
p1 <- tm_shape(blocks_sf) +
  tm_polygons("P_OWNEROCC", title = "Owner Occ", palette = "Blues") +
  tm_layout(legend.title.size = 0.7)
# with style = kmeans
p2 <- tm_shape(blocks_sf) +
  tm_polygons("P_OWNEROCC", title = "Owner Occ", palette = "Oranges",
              style = "kmeans") +
  tm_layout(legend.title.size = 0.7)
# with quantiles
p3 <- tm_shape(blocks_sf) +
  tm_polygons("P_OWNEROCC", title = "Owner Occ", palette = "Greens",
              breaks = c(0, round(quantileCuts(blocks$P_OWNEROCC, 6), 1))) +
  tm_layout(legend.title.size = 0.7)
p3

library(grid)
grid.newpage()

pushViewport(viewport(layout=grid.layout(1,3)))

print(p1, vp=viewport(layout.pos.col = 1, height = 5))
print(p2, vp=viewport(layout.pos.col = 2, height = 5))
print(p3, vp=viewport(layout.pos.col = 3, height = 5))

tm_shape(blocks_sf) +
  tm_polygons("P_OWNEROCC", title = "Owner Occ", palette = "-GnBu",
              breaks = c(0, round(quantileCuts(blocks$P_OWNEROCC, 6), 1)),
              legend.hist = T)+
  tm_scale_bar(width = 0.22) +
  tm_compass(position = c(0.8, 0.07)) +
  tm_layout(frame = F, title = "New Haven",
            title.size = 2, title.position = c(0.55, "top"),
            legend.hist.size = 0.5)

# add a projection to tracts data and convert tracts data to sf
proj4string(tracts) <- proj4string(blocks)
tracts_sf <- st_as_sf(tracts)
class(tracts_sf)
tracts_sf <- st_transform(tracts_sf, "+proj=longlat +ellps=WGS84")
# plot
tm_shape(blocks_sf) +
  tm_fill(col="POP1990", convert2density=TRUE,
          style="kmeans", title=expression("Population (per " * km^2 * ")"),
          legend.hist=F, id="name") +
  tm_borders("grey25", alpha=.5) +
  # add tracts context
  tm_shape(tracts_sf) +
  tm_borders("grey40", lwd=2)

# add an area in km^2 to blocks
blocks_sf$area = st_area(blocks_sf) / (1000*1000)
# calculate population density manually
summary(blocks_sf$POP1990/blocks_sf$are)

tm_shape(blocks_sf) +
  tm_fill(c("P_RENTROCC", "P_BLACK")) +
  tm_borders() +
  tm_layout(legend.format = list(digits = 0),
            legend.position = c("left", "bottom"),
            legend.text.size = 0.5,
            legend.title.size = 0.8)

### Mapping Point and Atttribute

tm_shape(blocks_sf) +
  tm_polygons("white") +
  tm_shape(breach_sf) +
  tm_dots(size = 0.5, shape = 19, col = "red", alpha = 1)

tm_shape(breach_sf) +
  tm_dots(size = 0.5, shape = 19, col = "red", alpha = 0.5)

# load the data
data(quakes)
# look at the first 6 records
head(quakes)

# define the coordinates
coords.tmp <- cbind(quakes$long, quakes$lat)
# create the SpatialPointsDataFrame
quakes.sp <- SpatialPointsDataFrame(coords.tmp,
                                    data = data.frame(quakes),
                                    proj4string = CRS("+proj=longlat "))
# convert to sf
quakes_sf <- st_as_sf(quakes.sp)

tm_shape(quakes_sf) +
  tm_dots(size = 0.5, alpha = 0.3)

library(grid)
# by size
p1 <- tm_shape(quakes_sf) +
  tm_bubbles("depth", scale = 1, shape = 19, alpha = 0.3,
             title.size="Quake Depths")
# by colour
p2 <- tm_shape(quakes_sf) +
  tm_dots("depth", shape = 19, alpha = 0.5, size = 0.6,
          palette = "PuBuGn",
          title="Quake Depths")
# Multiple plots using the grid package
grid.newpage()
# set up the layout
pushViewport(viewport(layout=grid.layout(1,2)))
# plot using he print command
print(p1, vp=viewport(layout.pos.col = 1, height = 5))

print(p2, vp=viewport(layout.pos.col = 2, height = 5))

# create the index
index <- quakes_sf$mag > 5.5
summary(index)
# select the subset assign to tmp
tmp <- quakes_sf[index,]
# plot the subset
tm_shape(tmp) +
  tm_dots(col = brewer.pal(5, "Reds")[4], shape = 19,
          alpha = 0.5, size = 1) +
  tm_layout(title="Quakes > 5.5",
            title.position = c("centre", "top"))

library(RgoogleMaps)
# define Lat and Lon
Lat <- as.vector(quakes$lat)
Long <- as.vector(quakes$long)
# get the map tiles
# you will need to be online
MyMap <- MapBackground(lat=Lat, lon=Long, zoom = 10,
                       maptype = "satellite")

# define a size vector
tmp <- 1+(quakes$mag - min(quakes$mag))/max(quakes$mag)
PlotOnStaticMap(MyMap,Lat,Long,cex=tmp,pch=1,col='#FB6A4A30')

### Mapping line and attribute

data(newhaven)
proj4string(roads) <- proj4string(blocks)
xmin <- bbox(roads)[1,1]
ymin <- bbox(roads)[2,1]

xmax <- xmin + diff(bbox(roads)[1,]) / 2
ymax <- ymin + diff(bbox(roads)[2,]) / 2

xx = as.vector(c(xmin, xmin, xmax, xmax, xmin))
yy = as.vector(c(ymin, ymax, ymax, ymin, ymin))

crds <- cbind(xx,yy)
Pl <- Polygon(crds)
ID <- "clip"
Pls <- Polygons(list(Pl), ID=ID)
Pls
SPls <- SpatialPolygons(list(Pls))
df <- data.frame(value=1, row.names=ID)
clip.bb <- SpatialPolygonsDataFrame(SPls, df)
proj4string(clip.bb) <- proj4string(blocks)
# 3. convert to sf
# convert the data to sf
clip_sf <- st_as_sf(clip.bb)
roads_sf <- st_as_sf(roads)
# 4. clip out the roads and the data frame
roads_tmp <- st_intersection(st_cast(clip_sf), roads_sf)

tm_shape(clip_sf) +
  tm_polygons("white") +
  tm_shape(roads_sf) +
  tm_lines(size = 0.5, shape = 19, col = "red", alpha = 1)+
  tm_shape(roads_tmp)+
  tm_lines(size = 0.5, shape = 19, col = "red", alpha = 1)


  which.quantile = function( x, probs, inside=TRUE ) {
    qnts = quantile( x, probs=probs, na.rm=TRUE )

    if ( inside ) {
      return( which(x < qnts[2]  & x > qnts[1] ) )
    } else {
      return( which(x > qnts[2]  | x < qnts[1] ) )
    }
  }


#!/usr/bin/env Rscript

library('ggplot2')

read_input <- function (path) {
    data.raw <- read.table(input, header=TRUE)

    sdev <- function (x) sqrt(var(x))
    data.mean <- aggregate(time ~ sched + name + threads, data.raw, mean)
    data.sdev <- aggregate(time ~ sched + name + threads, data.raw, sdev)
    data <- cbind(data.mean, sdev = data.sdev$time)
    return(data)
}

my_plot <- function (data, name, title = 'atata') {
    d <- data[data$name==name,]

    # t <- log(time)
    p <- ggplot(d, aes(x = threads, y = log(time), group = sched, color = sched)) +
        geom_line() +
        geom_point() +
        # geom_errorbar(
        #     aes(ymin = t - sdev, ymax = t + sdev),
        #     width = .2,
        #     position = position_dodge(0.05)
        # ) +
        labs(
            title = title,
            x = 'Number of threads',
            y = 'Execution time (us), log scale'
        ) +
        scale_color_manual(values=c('#999999','#E69F00', '#4286f4'))

    return(p)
}

process <- function (data, benchmark, title, output) {
    p <- my_plot(data, benchmark, title)

    path <- paste(output, '-', benchmark, '.png', sep='')
    ggsave(path, p, width = 10, height = 6)
}

args = commandArgs(trailingOnly=TRUE)
if (length(args) == 0) {
    stop("Usage: ./plot.r <data_file>", call.=FALSE)
}

input <- args[1]

data <- read_input(input)

process(data, 'fib', 'Fibonacci Number (43)', input)
process(data, 'dfs', 'Depth First Search (9^10 vertices)', input)
process(data, 'matmul', 'Matrix Multiplication (3500x3500)', input)
process(data, 'mergesort', 'Merge Sort (10^9 of 4 byte integers)', input)
process(data, 'blkmul', 'Block Matrix Multiplication (4096*4096)', input)


# Builds Random Forest model with 100 trees

library(randomForest)

# Fit RandomForest model w/ training data
dm_model <- randomForest(dm_model_formula, ntree=100, data=dm_traindf, importance=TRUE)

# Save MSE plot to PNG
png("rpt_forestMsePlot.png")
plot(dm_model, main='randomForest MSE Plot')
dev.off()

# Save VariableImportance to CSV
write.csv(importance(dm_model), file="rpt_forestIMP.csv", row.names=TRUE)

# Score full data
dm_scoreddf <- data.frame(predict(dm_model, dm_inputdf, type="prob"))
colnames(dm_scoreddf) <- c("P_DEFAULT_NEXT_MONTH0", "P_DEFAULT_NEXT_MONTH1")


# With this skript I intend to analyze whether there is a significant
#  difference between the populations in the control (absolute gene
#  expression) samples and between the two stress temperatures (28°C
#  and 32°C)

error.bar <- function(x, y, upper, lower=upper, length=0.05,...){
        if(length(x) != length(y) | length(y) !=length(lower) | length(lower) != length(upper))
        stop("vectors must be same length")
        arrows(x,upper, x, lower, angle=90, code=3, length=length, ...)
        }

error.bar2 <- function(x, y, upper, lower=upper, length=0.05,...){
        if(length(x) != length(y) | length(y) !=length(lower) | length(lower) != length(upper))
        stop("vectors must be same length")
        arrows(x,y+upper, x, y-lower, angle=90, code=3, length=length, ...)
        }

#####################################################################
#####################################################################
########## Absolute expression of control samples ###################
#####################################################################
#####################################################################
library("nparLD")

Alldata32 <- read.table("/home/alj/Documents/org_files/data/ScientificJournal/2012ScientificJournal/Dec/2012-12-18-Fs_32_NormalizedAmount_OutliersRemoved.txt",header=TRUE)

Alldata28 <- read.table("/home/alj/Documents/org_files/data/ScientificJournal/2012ScientificJournal/Dec/2012-12-18-Fs_28_NormalizedAmount_OutliersRemoved.txt",header=TRUE)

library(vegan)

# Remove all data with FoldChange==NA
# At this step I decide whether to take AllOutliersRemoved or AllBoxplotOutliersRemoved
FT32All <- as.data.frame(as.matrix(Alldata32[is.na(Alldata32$NormalizedAmount)!=TRUE,]))
Data32.2 <- tapply(FT32All$MeanCT,list(FT32All$Gene,FT32All$Population,FT32All$Treatment),length)

FT28All <- as.data.frame(as.matrix(Alldata28[is.na(Alldata28$NormalizedAmount)!=TRUE,]))
Data28.2 <- tapply(FT28All$MeanCT,list(FT28All$Gene,FT28All$Population,FT28All$Treatment),length)

############################################################################
############### Statistical analysis #######################################
############################################################################

# Do the analysis for the 32°C and the 28°C stress experiment and put
# the results for the three Hsps in a list.

FT <- rbind(FT28All,FT32All)
# Combine the stress data
FT$NormalizedAmount=as.numeric(as.vector(FT$NormalizedAmount))
FT$Population=as.factor(FT$Population)
FT$Treatment=as.factor(FT$Treatment)
################### HSP70

HSP70Compare <- subset(FT,FT$Gene=="HSP70")
HSP90Compare <- subset(FT,FT$Gene=="HSP90")
sHSPCompare <- subset(FT,FT$Gene=="sHSP")

HSPs <- c("HSP70Compare","HSP90Compare","sHSPCompare")

Meanslist28 <- vector("list",length(HSPs))
SElist28upper <- vector("list",length(HSPs))
SElist28lower <- vector("list",length(HSPs))
significancelist28 <- vector("list",length(HSPs))
Meanslist32 <- vector("list",length(HSPs))
SElist32upper <- vector("list",length(HSPs))
SElist32lower <- vector("list",length(HSPs))
significancelist32 <- vector("list",length(HSPs))

#########################################
######### Log transformation and ANOVA ##
#########################################
library("lawstat") # Provides the levene test to test for heteroscedasticity

# The sHSP expression in the control samples from Spain (28°C) are
# higher than for the other populations. I want to see if a
# transformation of the data, followed by a normal ANOVA indicates
# here a significant difference, since the PERMANOVA analysis does
# not. I tested it and a log-transformation gives a statistical
# significance if I apply an ANOVA on it.

# I regard the normal ANOVA analysis only to be problematic when there
# is an indication for non-normality or heteroscedasticity with a p-value<0.01

# I do log-transformation only when necessary and then back-transform the data with exp(result)

# Here I can change which gene shall be analyzed
l=1
###########
### HSP 70
###########

d <- get(HSPs[l])
Hs.Pop0 <- subset(d,d$Treatment==0,drop=TRUE)

# 28°C
shapiro.test(log(Hs.Pop0$NormalizedAmount))
levene.test(log(Hs.Pop0$NormalizedAmount),Hs.Pop0$Population)
# log-transformation necessary!
model <- aov(log(Hs.Pop0$NormalizedAmount) ~ Hs.Pop0$Population*Hs.Pop0$Temperature)
summary(model)
significances <- TukeyHSD(model)[[3]][,4]

significancesTrue <- significances<0.05
names(significancesTrue) <- c("28F-28D",
                              "28N-28D",
                              "28S-28D",
                              "32D-28D",
                              "32F-28D",
                              "32N-28D",
                              "32S-28D",
                              "28N-28F",
                              "28S-28F",
                              "32D-28F",
                              "32F-28F",
                              "32N-28F",
                              "32S-28F",
                              "28S-28N",
                              "32D-28N",
                              "32F-28N",
                              "32N-28N",
                              "32S-28N",
                              "32D-28S",
                              "32F-28S",
                              "32N-28S",
                              "32S-28S",
                              "32F-32D",
                              "32N-32D",
                              "32S-32D",
                              "32N-32F",
                              "32S-32F",
                              "32S-32N")
library("multcompView")
Comparisons <- c("28N","28D","28F","28S","32N","32D","32F","32S")
Letters <- multcompLetters(significancesTrue)$Letters[match(c("28N","28D","28F","28S","32N","32D","32F","32S"),names(multcompLetters(significancesTrue)$Letters))]

# Calculating the Means and SEs

d28 <- d[d$Temperature==28,]
d32 <- d[d$Temperature==32,]

d28.Means <- as.matrix(tapply(as.numeric(as.vector(log(d28$NormalizedAmount))),list(as.factor(as.vector(d28$Population)),as.vector(d28$Treatment)),mean))
d28.Means <- as.matrix(rbind(d28.Means[3,c(1,2,4,3)],d28.Means[1,c(1,2,4,3)],d28.Means[2,c(1,2,4,3)],d28.Means[4,c(1,2,4,3)]))
rownames(d28.Means) <- c("Norway","Denmark","France","Spain")
#Back-transformation
d28.Means2 <- d28.Means
d28.Means <- exp(d28.Means)

Meanslist28[[l]] <- d28.Means

library(plotrix)

d28.SEs <- tapply(as.numeric(as.vector(log(d28$NormalizedAmount))),list(as.factor(as.vector(d28$Population)),as.vector(d28$Treatment)),std.error)
d28.SEs <- as.matrix(rbind(d28.SEs[3,c(1,2,4,3)],d28.SEs[1,c(1,2,4,3)],d28.SEs[2,c(1,2,4,3)],d28.SEs[4,c(1,2,4,3)]))
rownames(d28.SEs) <- c("Norway","Denmark","France","Spain")
#Back-transformation

d28.UpperSEs <- exp(d28.Means2+d28.SEs)
d28.LowerSEs <- exp(d28.Means2-d28.SEs)

SElist28upper[[l]] <- d28.UpperSEs
SElist28lower[[l]] <- d28.LowerSEs

d32.Means <- as.matrix(tapply(as.numeric(as.vector(log(d32$NormalizedAmount))),list(as.factor(as.vector(d32$Population)),as.vector(d32$Treatment)),mean))
d32.Means <- as.matrix(rbind(d32.Means[3,c(1,2,4,3)],d32.Means[1,c(1,2,4,3)],d32.Means[2,c(1,2,4,3)],d32.Means[4,c(1,2,4,3)]))
rownames(d32.Means) <- c("Norway","Denmark","France","Spain")
#Back-transformation
d32.Means2 <- d32.Means
d32.Means <- exp(d32.Means)

Meanslist32[[l]] <- d32.Means

library(plotrix)

d32.SEs <- tapply(as.numeric(as.vector(log(d32$NormalizedAmount))),list(as.factor(as.vector(d32$Population)),as.vector(d32$Treatment)),std.error)
d32.SEs <- as.matrix(rbind(d32.SEs[3,c(1,2,4,3)],d32.SEs[1,c(1,2,4,3)],d32.SEs[2,c(1,2,4,3)],d32.SEs[4,c(1,2,4,3)]))
rownames(d32.SEs) <- c("Norway","Denmark","France","Spain")
#Back-transformation

d32.UpperSEs <- exp(d32.Means2+d32.SEs)
d32.LowerSEs <- exp(d32.Means2-d32.SEs)

SElist32upper[[l]] <- d32.UpperSEs
SElist32lower[[l]] <- d32.LowerSEs

significancelist28[[l]] <-  Letters[1:4]
significancelist32[[l]] <-  Letters[5:8]

# Here I can change which gene shall be analyzed
l=2
###########
### HSP 90
###########

d <- get(HSPs[l])
Hs.Pop0 <- subset(d,d$Treatment==0,drop=TRUE)

shapiro.test(log(Hs.Pop0$NormalizedAmount))
levene.test(log(Hs.Pop0$NormalizedAmount),Hs.Pop0$Population)
# log-transformation necessary!
model <- aov(log(Hs.Pop0$NormalizedAmount) ~ Hs.Pop0$Population*Hs.Pop0$Temperature)
summary(model)
significances <- TukeyHSD(model)[[3]][,4]

significancesTrue <- significances<0.05
names(significancesTrue) <- c("28F-28D",
                              "28N-28D",
                              "28S-28D",
                              "32D-28D",
                              "32F-28D",
                              "32N-28D",
                              "32S-28D",
                              "28N-28F",
                              "28S-28F",
                              "32D-28F",
                              "32F-28F",
                              "32N-28F",
                              "32S-28F",
                              "28S-28N",
                              "32D-28N",
                              "32F-28N",
                              "32N-28N",
                              "32S-28N",
                              "32D-28S",
                              "32F-28S",
                              "32N-28S",
                              "32S-28S",
                              "32F-32D",
                              "32N-32D",
                              "32S-32D",
                              "32N-32F",
                              "32S-32F",
                              "32S-32N")
library("multcompView")
Comparisons <- c("28N","28D","28F","28S","32N","32D","32F","32S")
Letters <- multcompLetters(significancesTrue)$Letters[match(c("28N","28D","28F","28S","32N","32D","32F","32S"),names(multcompLetters(significancesTrue)$Letters))]

# Calculating the Means and SEs

d28 <- d[d$Temperature==28,]
d32 <- d[d$Temperature==32,]

d28.Means <- as.matrix(tapply(as.numeric(as.vector(log(d28$NormalizedAmount))),list(as.factor(as.vector(d28$Population)),as.vector(d28$Treatment)),mean))
d28.Means <- as.matrix(rbind(d28.Means[3,c(1,2,4,3)],d28.Means[1,c(1,2,4,3)],d28.Means[2,c(1,2,4,3)],d28.Means[4,c(1,2,4,3)]))
rownames(d28.Means) <- c("Norway","Denmark","France","Spain")
#Back-transformation
d28.Means2 <- d28.Means
d28.Means <- exp(d28.Means)

Meanslist28[[l]] <- d28.Means

library(plotrix)

d28.SEs <- tapply(as.numeric(as.vector(log(d28$NormalizedAmount))),list(as.factor(as.vector(d28$Population)),as.vector(d28$Treatment)),std.error)
d28.SEs <- as.matrix(rbind(d28.SEs[3,c(1,2,4,3)],d28.SEs[1,c(1,2,4,3)],d28.SEs[2,c(1,2,4,3)],d28.SEs[4,c(1,2,4,3)]))
rownames(d28.SEs) <- c("Norway","Denmark","France","Spain")
#Back-transformation

d28.UpperSEs <- exp(d28.Means2+d28.SEs)
d28.LowerSEs <- exp(d28.Means2-d28.SEs)

SElist28upper[[l]] <- d28.UpperSEs
SElist28lower[[l]] <- d28.LowerSEs

d32.Means <- as.matrix(tapply(as.numeric(as.vector(log(d32$NormalizedAmount))),list(as.factor(as.vector(d32$Population)),as.vector(d32$Treatment)),mean))
d32.Means <- as.matrix(rbind(d32.Means[3,c(1,2,4,3)],d32.Means[1,c(1,2,4,3)],d32.Means[2,c(1,2,4,3)],d32.Means[4,c(1,2,4,3)]))
rownames(d32.Means) <- c("Norway","Denmark","France","Spain")
#Back-transformation
d32.Means2 <- d32.Means
d32.Means <- exp(d32.Means)

Meanslist32[[l]] <- d32.Means

library(plotrix)

d32.SEs <- tapply(as.numeric(as.vector(log(d32$NormalizedAmount))),list(as.factor(as.vector(d32$Population)),as.vector(d32$Treatment)),std.error)
d32.SEs <- as.matrix(rbind(d32.SEs[3,c(1,2,4,3)],d32.SEs[1,c(1,2,4,3)],d32.SEs[2,c(1,2,4,3)],d32.SEs[4,c(1,2,4,3)]))
rownames(d32.SEs) <- c("Norway","Denmark","France","Spain")
#Back-transformation

d32.UpperSEs <- exp(d32.Means2+d32.SEs)
d32.LowerSEs <- exp(d32.Means2-d32.SEs)

SElist32upper[[l]] <- d32.UpperSEs
SElist32lower[[l]] <- d32.LowerSEs

significancelist28[[l]] <-  Letters[1:4]
significancelist32[[l]] <-  Letters[5:8]

# Here I can change which gene shall be analyzed
l=3
###########
### sHSP
###########

d <- get(HSPs[l])
Hs.Pop0 <- subset(d,d$Treatment==0,drop=TRUE)

shapiro.test(log(Hs.Pop0$NormalizedAmount))
levene.test(log(Hs.Pop0$NormalizedAmount),Hs.Pop0$Population)
# log-transformation necessary!
model <- aov(log(Hs.Pop0$NormalizedAmount) ~ Hs.Pop0$Population*Hs.Pop0$Temperature)
summary(model)
significances <- TukeyHSD(model)[[3]][,4]

significancesTrue <- significances<0.05
names(significancesTrue) <- c("28F-28D",
                              "28N-28D",
                              "28S-28D",
                              "32D-28D",
                              "32F-28D",
                              "32N-28D",
                              "32S-28D",
                              "28N-28F",
                              "28S-28F",
                              "32D-28F",
                              "32F-28F",
                              "32N-28F",
                              "32S-28F",
                              "28S-28N",
                              "32D-28N",
                              "32F-28N",
                              "32N-28N",
                              "32S-28N",
                              "32D-28S",
                              "32F-28S",
                              "32N-28S",
                              "32S-28S",
                              "32F-32D",
                              "32N-32D",
                              "32S-32D",
                              "32N-32F",
                              "32S-32F",
                              "32S-32N")
library("multcompView")
Comparisons <- c("28N","28D","28F","28S","32N","32D","32F","32S")
Letters <- multcompLetters(significancesTrue)$Letters[match(c("28N","28D","28F","28S","32N","32D","32F","32S"),names(multcompLetters(significancesTrue)$Letters))]

# Calculating the Means and SEs

d28 <- d[d$Temperature==28,]
d32 <- d[d$Temperature==32,]

d28.Means <- as.matrix(tapply(as.numeric(as.vector(log(d28$NormalizedAmount))),list(as.factor(as.vector(d28$Population)),as.vector(d28$Treatment)),mean))
d28.Means <- as.matrix(rbind(d28.Means[3,c(1,2,4,3)],d28.Means[1,c(1,2,4,3)],d28.Means[2,c(1,2,4,3)],d28.Means[4,c(1,2,4,3)]))
rownames(d28.Means) <- c("Norway","Denmark","France","Spain")
#Back-transformation
d28.Means2 <- d28.Means
d28.Means <- exp(d28.Means)

Meanslist28[[l]] <- d28.Means

library(plotrix)

d28.SEs <- tapply(as.numeric(as.vector(log(d28$NormalizedAmount))),list(as.factor(as.vector(d28$Population)),as.vector(d28$Treatment)),std.error)
d28.SEs <- as.matrix(rbind(d28.SEs[3,c(1,2,4,3)],d28.SEs[1,c(1,2,4,3)],d28.SEs[2,c(1,2,4,3)],d28.SEs[4,c(1,2,4,3)]))
rownames(d28.SEs) <- c("Norway","Denmark","France","Spain")
#Back-transformation

d28.UpperSEs <- exp(d28.Means2+d28.SEs)
d28.LowerSEs <- exp(d28.Means2-d28.SEs)

SElist28upper[[l]] <- d28.UpperSEs
SElist28lower[[l]] <- d28.LowerSEs

d32.Means <- as.matrix(tapply(as.numeric(as.vector(log(d32$NormalizedAmount))),list(as.factor(as.vector(d32$Population)),as.vector(d32$Treatment)),mean))
d32.Means <- as.matrix(rbind(d32.Means[3,c(1,2,4,3)],d32.Means[1,c(1,2,4,3)],d32.Means[2,c(1,2,4,3)],d32.Means[4,c(1,2,4,3)]))
rownames(d32.Means) <- c("Norway","Denmark","France","Spain")
#Back-transformation
d32.Means2 <- d32.Means
d32.Means <- exp(d32.Means)

Meanslist32[[l]] <- d32.Means

library(plotrix)

d32.SEs <- tapply(as.numeric(as.vector(log(d32$NormalizedAmount))),list(as.factor(as.vector(d32$Population)),as.vector(d32$Treatment)),std.error)
d32.SEs <- as.matrix(rbind(d32.SEs[3,c(1,2,4,3)],d32.SEs[1,c(1,2,4,3)],d32.SEs[2,c(1,2,4,3)],d32.SEs[4,c(1,2,4,3)]))
rownames(d32.SEs) <- c("Norway","Denmark","France","Spain")
#Back-transformation

d32.UpperSEs <- exp(d32.Means2+d32.SEs)
d32.LowerSEs <- exp(d32.Means2-d32.SEs)

SElist32upper[[l]] <- d32.UpperSEs
SElist32lower[[l]] <- d32.LowerSEs

significancelist28[[l]] <-  Letters[1:4]
significancelist32[[l]] <-  Letters[5:8]

names(Meanslist28) <- HSPs
names(SElist28upper) <- HSPs
names(SElist28lower) <- HSPs
names(significancelist28) <- HSPs
names(Meanslist32) <- HSPs
names(SElist32upper) <- HSPs
names(SElist32lower) <- HSPs
names(significancelist32) <- HSPs

AbsMeanslist28 <- Meanslist28
AbsSElist28upper <- SElist28upper
AbsSElist28lower <- SElist28lower
Abssignificancelist28 <- significancelist28

AbsMeanslist32 <- Meanslist32
AbsSElist32upper <- SElist32upper
AbsSElist32lower <- SElist32lower
Abssignificancelist32 <- significancelist32

error.bar <- function(x, y, upper, lower=upper, length=0.05,...){
        if(length(x) != length(y) | length(y) !=length(lower) | length(lower) != length(upper))
        stop("vectors must be same length")
        arrows(x,upper, x, lower, angle=90, code=3, length=length, ...)
        }

error.bar2 <- function(x, y, upper, lower=upper, length=0.05,...){
        if(length(x) != length(y) | length(y) !=length(lower) | length(lower) != length(upper))
        stop("vectors must be same length")
        arrows(x,y+upper, x, y-lower, angle=90, code=3, length=length, ...)
        }

######################################################
############# Plotting ###############################
######################################################

cnorway <- "#fdfdfd"
cdenmark <- "#808080"
cfrance <- "#dfdfdf"
cspain <- "#202020"

######################################################
############# Plotting ###############################
######################################################

########## Plot for Control levels
png(filename="/home/alj/Documents/writing/2012HSR/2012HeatShockResponse/Audioslides/images/Controls_Comparisons.png",width=60,height=65,units='mm',res=100,pointsize=10)
par(xpd=NA,mar=c(1,0,2,0),oma=c(3,6.5,0,0),mgp=c(4,2,1),font=1,ps=10,mfrow=c(2,1),bg=NA)

# 28°C stress absolute control values
Means28 <- cbind(AbsMeanslist28$HSP70Compare[,1],AbsMeanslist28$HSP90Compare[,1],AbsMeanslist28$sHSPCompare[,1])
SEs28upper <- cbind(AbsSElist28upper$HSP70Compare[,1],AbsSElist28upper$HSP90Compare[,1],AbsSElist28upper$sHSPCompare[,1])
SEs28lower <- cbind(AbsSElist28lower$HSP70Compare[,1],AbsSElist28lower$HSP90Compare[,1],AbsSElist28lower$sHSPCompare[,1])
significance28 <- c(Abssignificancelist28$HSP70Compare,Abssignificancelist28$HSP90Compare,Abssignificancelist28$sHSPCompare)

barx <- barplot(Means28[,3], beside=TRUE,col=c(rgb(51,102,0,maxColorValue=255),rgb(255,221,17,maxColorValue=255),rgb(102,51,153,maxColorValue=255),rgb(51,221,238,maxColorValue=255)),border="white", ylim=c(0.001,10),axis.lty=1,lwd=1,cex.main=1,cex.lab=1,cex.axis=1,las=1,cex.names=1,cex.main=1.2,log="y",axes=FALSE,main="",names.arg="",xaxt="n")
axis(2, at=c(0.001,0.1,10),labels=as.character(c(0.001,0.1,10)),las=1)

lines(x=c(5.5,5.5),y=c(0.001,10000000),lty=2)
lines(x=c(10.5,10.5),y=c(0.001,10000000),lty=2)
error.bar(barx,Means28[,3],upper=SEs28upper[,3],lower=SEs28lower[,3],lwd=1)

distances <- Means28[,3]+3

text(barx,distances,significance28[9:12],cex=1)

# 32°C stress absolute control values
Means32 <- cbind(AbsMeanslist32$HSP70Compare[,1],AbsMeanslist32$HSP90Compare[,1],AbsMeanslist32$sHSPCompare[,1])
SEs32upper <- cbind(AbsSElist32upper$HSP70Compare[,1],AbsSElist32upper$HSP90Compare[,1],AbsSElist32upper$sHSPCompare[,1])
SEs32lower <- cbind(AbsSElist32lower$HSP70Compare[,1],AbsSElist32lower$HSP90Compare[,1],AbsSElist32lower$sHSPCompare[,1])
significance32 <- c(Abssignificancelist32$HSP70Compare,Abssignificancelist32$HSP90Compare,Abssignificancelist32$sHSPCompare)

barx <- barplot(Means32[,3], beside=TRUE,col=c(rgb(51,102,0,maxColorValue=255),rgb(255,221,17,maxColorValue=255),rgb(102,51,153,maxColorValue=255),rgb(51,221,238,maxColorValue=255)),border="white", ylim=c(0.001,10),axis.lty=1,xaxt="n",lwd=1,cex.main=1,cex.lab=1,cex.axis=1,las=1,cex.names=1,cex.main=1.2,log="y",axes=FALSE,main="")
axis(2, at=c(0.001,0.1,10),labels=as.character(c(0.001,0.1,10)),las=1)

error.bar(barx,Means32[,3],upper=SEs32upper[,3],lower=SEs32lower[,3],lwd=1)

distances <- Means32[,3]+3

text(barx,distances,significance32[9:12],cex=1)

dev.off()
dev.off(dev.prev())


## 3. Introducing The caret Library ##

set.seed(1)
library(caret)
train_indices <- createDataPartition(y = dc_listings[["tidy_price"]],
                                     p = 0.7,
                                     list = FALSE)
train_listings <- dc_listings[train_indices,]
test_listings <- dc_listings[-train_indices,]

## 5. Training The Algorithm ##

set.seed(1)
library(caret)
train_indices <- createDataPartition(y = dc_listings[["tidy_price"]],
                                     p = 0.7,
                                     list = FALSE)
train_listings <- dc_listings[train_indices,]
test_listings <- dc_listings[-train_indices,]
train_control <- trainControl(method = "none")
knn_model <- train(tidy_price ~ accommodates + maximum_nights,
                   data = train_listings,
                   method = "knn",
                   trControl = train_control)

## 6. Create Predictions On The Test Data ##

set.seed(1)
library(caret)
train_indices <- createDataPartition(y = dc_listings[["tidy_price"]],
                                     p = 0.7,
                                     list = FALSE)
train_listings <- dc_listings[train_indices,]
test_listings <- dc_listings[-train_indices,]
train_control <- trainControl(method = "none")
knn_model <- train(tidy_price ~ accommodates + maximum_nights,
                   data = train_listings,
                   method = "knn",
                   trControl = train_control)
test_predictions <- predict(knn_model, newdata = test_listings)

## 7. Evaluating Predictions ##

set.seed(1)
library(caret)
train_indices <- createDataPartition(y = dc_listings[["tidy_price"]],
                                     p = 0.7,
                                     list = FALSE)
train_listings <- dc_listings[train_indices,]
test_listings <- dc_listings[-train_indices,]
train_control <- trainControl(method = "none")
knn_model <- train(tidy_price ~ accommodates + maximum_nights,
                   data = train_listings,
                   method = "knn",
                   trControl = train_control)
test_predictions <- predict(knn_model, newdata = test_listings)
test_listings <- test_listings %>%
  mutate(
    error = tidy_price - test_predictions
  )

## 8. Summarizing Errors Into a Single Metric ##

set.seed(1)
library(caret)
train_indices <- createDataPartition(y = dc_listings[["tidy_price"]],
                                     p = 0.7,
                                     list = FALSE)
train_listings <- dc_listings[train_indices,]
test_listings <- dc_listings[-train_indices,]
train_control <- trainControl(method = "none")
knn_model <- train(tidy_price ~ accommodates + maximum_nights,
                   data = train_listings,
                   method = "knn",
                   trControl = train_control)
test_predictions <- predict(knn_model, newdata = test_listings)
test_listings <- test_listings %>%
  mutate(
    error = tidy_price - test_predictions
  )
test_listings <- test_listings %>%
  mutate(
    squared_error = error^2
  )

rmse <- sqrt(mean(test_listings$squared_error))

Data Analyst in R/Step 6 - Predictive Modeling and Machine Learning in R/2. Machine Learning Fundamentals in R/2. Evaluating Model Performance.r


  #Calculating values for new column
  df$EV_Diff <- df$EV1 - df$EV2
  #Checking values for new column
  df$EV_Diff
  #Rinse, Wash...
  df$Sample_Diff <- df$samplingCount_safe - df$samplingCount_risk
  #...Repeat
  df$Sample_Diff


# Plotting raster data using the `rasterVis` R package
# Data used: OS Terrain® 50
# (<https://osdatahub.os.uk/downloads/open/Terrain50>)

# import libraries
library("rasterVis")

# set plot resolution
options(repr.plot.res = 200)

# read the digital terrain model
# OS Terrain 50
dtm <- merge(
    raster("data/Terrain50/sn91_OST50GRID_20210507/SN91.asc"),
    raster("data/Terrain50/sn92_OST50GRID_20210507/SN92.asc"),
    raster("data/Terrain50/so01_OST50GRID_20210507/SO01.asc"),
    raster("data/Terrain50/so02_OST50GRID_20210507/SO02.asc")
)

# view the DTM
dtm

# plot the DTM
levelplot(
    dtm,
    xlab = "Easting (m)",
    ylab = "Northing (m)",
    main = "50 m Digital Terrain Model of the Brecon Beacons",
    cuts = 49,
    col.regions = hcl.colors(n = 50, palette = "Temps")
) +
layer({
    # add a north arrow
    SpatialPolygonsRescale(
        layout.north.arrow(), offset = c(293000, 227000), scale = 2000
    )
    xs <- seq(292000, 292000 + 3000, by = 1500)
    # draw a scale bar
    grid.rect(
        x = xs,
        y = 225750,
        width = 1500,
        height = 250,
        gp = gpar(fill = rep(c("white", "black"), 2)),
        default.units = "native"
    )
    # add scale bar labels
    grid.text(
        x = seq(292000, 292000 + 4500, by = 1500) - 650,
        y = 225100, seq(0, 4500, by = 1500),
        gp = gpar(cex = .6),
        default.units = "native"
    )
    # add scale bar unit
    grid.text(
        x = 296300,
        y = 225750,
        "m",
        gp = gpar(cex = .6),
        default.units = "native"
    )
    # add projection info
    grid.text(
        x = 293500,
        y = 226500,
        "British National Grid",
        gp = gpar(cex = .6),
        default.units = "native"
    )
    # add copyright info
    grid.text(
        x = 302000,
        y = 210500,
        "Contains OS data © Crown copyright and database right 2021",
        gp = gpar(cex = .6),
        default.units = "native"
    )
})

# contours
contourplot(
    dtm,
    xlab = "Easting (m)",
    ylab = "Northing (m)",
    main = "50 m Digital Terrain Model of the Brecon Beacons",
    cuts = 5
) +
layer({
    # add a north arrow
    SpatialPolygonsRescale(
        layout.north.arrow(), offset = c(293000, 227000), scale = 2000
    )
    xs <- seq(292000, 292000 + 3000, by = 1500)
    # draw a scale bar
    grid.rect(
        x = xs,
        y = 225750,
        width = 1500,
        height = 250,
        gp = gpar(fill = rep(c("white", "black"), 2)),
        default.units = "native"
    )
    # add scale bar labels
    grid.text(
        x = seq(292000, 292000 + 4500, by = 1500) - 650,
        y = 225100, seq(0, 4500, by = 1500),
        gp = gpar(cex = .6),
        default.units = "native"
    )
    # add scale bar unit
    grid.text(
        x = 296300,
        y = 225750,
        "m",
        gp = gpar(cex = .6),
        default.units = "native"
    )
    # add projection info
    grid.text(
        x = 293500,
        y = 226500,
        "British National Grid",
        gp = gpar(cex = .6),
        default.units = "native"
    )
    # add copyright info
    grid.text(
        x = 302000,
        y = 210500,
        "Contains OS data © Crown copyright and database right 2021",
        gp = gpar(cex = .6),
        default.units = "native"
    )
})

# DTM with contours
levelplot(
    dtm,
    xlab = "Easting (m)",
    ylab = "Northing (m)",
    main = "50 m Digital Terrain Model of the Brecon Beacons",
    cuts = 5,
    col.regions = hcl.colors(n = 50, palette = "Temps"),
    contour = TRUE
) +
layer({
    # add a north arrow
    SpatialPolygonsRescale(
        layout.north.arrow(), offset = c(293000, 227000), scale = 2000
    )
    xs <- seq(292000, 292000 + 3000, by = 1500)
    # draw a scale bar
    grid.rect(
        x = xs,
        y = 225750,
        width = 1500,
        height = 250,
        gp = gpar(fill = rep(c("white", "black"), 2)),
        default.units = "native"
    )
    # add scale bar labels
    grid.text(
        x = seq(292000, 292000 + 4500, by = 1500) - 650,
        y = 225100, seq(0, 4500, by = 1500),
        gp = gpar(cex = .6),
        default.units = "native"
    )
    # add scale bar unit
    grid.text(
        x = 296300,
        y = 225750,
        "m",
        gp = gpar(cex = .6),
        default.units = "native"
    )
    # add projection info
    grid.text(
        x = 293500,
        y = 226500,
        "British National Grid",
        gp = gpar(cex = .6),
        default.units = "native"
    )
    # add copyright info
    grid.text(
        x = 302000,
        y = 210500,
        "Contains OS data © Crown copyright and database right 2021",
        gp = gpar(cex = .6),
        default.units = "native"
    )
})


model_penman <- function (evapoTranspirationPriestlyTaylor = 449.367,
         hslope = 0.584,
         VPDair = 2.19,
         psychrometricConstant = 0.66,
         Alpha = 1.5,
         lambdaV = 2.454,
         rhoDensityAir = 1.225,
         specificHeatCapacityAir = 0.00101,
         conductance = 598.685){
    #'- Name: Penman -Version: 1.0, -Time step: 1
    #'- Description:
    #'            * Title: Penman Model
    #'            * Author: Pierre Martre
    #'            * Reference: Modelling energy balance in the wheat crop model SiriusQuality2:
    #'            Evapotranspiration and canopy and soil temperature calculations
    #'            * Institution: INRA/LEPSE Montpellier
    #'            * Abstract: This method is used when wind and vapor pressure daily data are available
    #'
    #'- inputs:
    #'            * name: evapoTranspirationPriestlyTaylor
    #'                          ** description : evapoTranspiration of Priestly Taylor
    #'                          ** variablecategory : rate
    #'                          ** datatype : DOUBLE
    #'                          ** default : 449.367
    #'                          ** min : 0
    #'                          ** max : 10000
    #'                          ** unit : g m-2 d-1
    #'                          ** uri : http://www1.clermont.inra.fr/siriusquality/?page_id=547
    #'                          ** inputtype : variable
    #'            * name: hslope
    #'                          ** description : the slope of saturated vapor pressure temperature curve at a given temperature
    #'                          ** variablecategory : auxiliary
    #'                          ** datatype : DOUBLE
    #'                          ** default : 0.584
    #'                          ** min : 0
    #'                          ** max : 1000
    #'                          ** unit : hPa °C-1
    #'                          ** uri : http://www1.clermont.inra.fr/siriusquality/?page_id=547
    #'                          ** inputtype : variable
    #'            * name: VPDair
    #'                          ** description :  vapour pressure density
    #'                          ** variablecategory : auxiliary
    #'                          ** datatype : DOUBLE
    #'                          ** default : 2.19
    #'                          ** min : 0
    #'                          ** max : 1000
    #'                          ** unit : hPa
    #'                          ** uri : http://www1.clermont.inra.fr/siriusquality/?page_id=547
    #'                          ** inputtype : variable
    #'            * name: psychrometricConstant
    #'                          ** description : psychrometric constant
    #'                          ** parametercategory : constant
    #'                          ** datatype : DOUBLE
    #'                          ** default : 0.66
    #'                          ** min : 0
    #'                          ** max : 1
    #'                          ** unit :
    #'                          ** uri : http://www1.clermont.inra.fr/siriusquality/?page_id=547
    #'                          ** inputtype : parameter
    #'            * name: Alpha
    #'                          ** description : Priestley-Taylor evapotranspiration proportionality constant
    #'                          ** parametercategory : constant
    #'                          ** datatype : DOUBLE
    #'                          ** default : 1.5
    #'                          ** min : 0
    #'                          ** max : 100
    #'                          ** unit :
    #'                          ** uri : http://www1.clermont.inra.fr/siriusquality/?page_id=547
    #'                          ** inputtype : parameter
    #'            * name: lambdaV
    #'                          ** description : latent heat of vaporization of water
    #'                          ** parametercategory : constant
    #'                          ** datatype : DOUBLE
    #'                          ** default : 2.454
    #'                          ** min : 0
    #'                          ** max : 10
    #'                          ** unit :
    #'                          ** uri : http://www1.clermont.inra.fr/siriusquality/?page_id=547
    #'                          ** inputtype : parameter
    #'            * name: rhoDensityAir
    #'                          ** description : Density of air
    #'                          ** parametercategory : constant
    #'                          ** datatype : DOUBLE
    #'                          ** default : 1.225
    #'                          ** unit :
    #'                          ** uri : http://www1.clermont.inra.fr/siriusquality/?page_id=547
    #'                          ** inputtype : parameter
    #'            * name: specificHeatCapacityAir
    #'                          ** description : Specific heat capacity of dry air
    #'                          ** parametercategory : constant
    #'                          ** datatype : DOUBLE
    #'                          ** default : 0.00101
    #'                          ** min : 0
    #'                          ** max : 1
    #'                          ** unit :
    #'                          ** uri : http://www1.clermont.inra.fr/siriusquality/?page_id=547
    #'                          ** inputtype : parameter
    #'            * name: conductance
    #'                          ** description : conductance
    #'                          ** variablecategory : state
    #'                          ** datatype : DOUBLE
    #'                          ** min : 0
    #'                          ** max : 10000
    #'                          ** default : 598.685
    #'                          ** unit : m d-1
    #'                          ** uri : http://www1.clermont.inra.fr/siriusquality/?page_id=547
    #'                          ** inputtype : variable
    #'- outputs:
    #'            * name: evapoTranspirationPenman
    #'                          ** description :  evapoTranspiration of Penman Monteith
    #'                          ** variablecategory : rate
    #'                          ** datatype : DOUBLE
    #'                          ** min : 0
    #'                          ** max : 5000
    #'                          ** unit : g m-2 d-1
    #'                          ** uri : http://www1.clermont.inra.fr/siriusquality/?page_id=547
    evapoTranspirationPenman <- evapoTranspirationPriestlyTaylor / Alpha + (1000.0 * (rhoDensityAir * specificHeatCapacityAir * VPDair * conductance / (lambdaV * (hslope + psychrometricConstant))))
    return (list('evapoTranspirationPenman' = evapoTranspirationPenman))
}


#' Transform a data.frame with axes and value into an array
#'
#' The construct() function can be called either with the data.frame as the
#' first argument or the formula and then specify `data=<data.frame>`
#'
#' @param data           A data frame
#' @param formula        A formula: value ~ axis1 [+ axis2 + axis n ..]
#' @param fill           Value to fill array with if undefined
#' @param name_axes      Keep column names of `data` as axis names
#' @return               A structured array
#' @export
construct = function(data, formula=guess_structure(data), fill=NA,
                     name_axes=TRUE) {
    if (!is.data.frame(data))
        stop("`data` needs to reference a data.frame")

    dep_var = all.vars(formula[[2]])
    if (length(dep_var) != 1)
        stop("The dependent variable (left side of ~) needs to reference exactly one variable")
    indep_vars = all.vars(formula[[3]]) # include empty factor levels here?
    axis_NA = apply(is.na(data[indep_vars]), 1, any) # taking quite a long time
    if (any(axis_NA)) {
        warning("Omitting ", sum(axis_NA), " rows where axis columns are NA")
        data = data[!axis_NA,]
    }
    axes = data[indep_vars]
    values = data[[dep_var]]
    if (any(duplicated(axes))) # taking quite a long time
        stop("Duplicated entries in `data` are not allowed")

    dimNames = lapply(axes, unique)
    ndim = sapply(dimNames, length)

    order_df = t(mapply(base::match, axes, dimNames) - 1)
    mult = c(1, rev(cumprod(ndim[-length(ndim)])))
    ar_idx = colSums(order_df * mult) + 1

    idx = rep(fill, prod(ndim))
    idx[ar_idx] = values
    array(idx, dim=unname(ndim), dimnames=dimNames)
}


##
# Functions to support error_analysis.r.

mcse_plot <- function(summary_standard,
                      summary_laplace,
                      summary_benchmark, pars) {
  mean <- c(summary_standard[, 1], summary_benchmark[, 1],
            summary_laplace[, 1])
  mcse <- c(summary_standard[, 2], summary_benchmark[, 2],
            summary_laplace[, 2])

  parm <- rep(pars, 3)
  method <- rep(c("(full) HMC", "benchmark", "HMC + Laplace"),
                each = length(pars))

  # method <- rep(c("(full) HMC", "HMC + Laplace", "benchmark"))
  ggplot(data = data.frame(mean, mcse, parm, method),
         aes(x = method, y = mean, ymin = mean - mcse, ymax = mean + mcse,
             color = method)) + # geom_point(size = 3) +
    facet_wrap(~parm, scale = "free") + geom_pointrange(shape = 20) +
    theme_bw() +
    theme(axis.title.x=element_blank(),
          axis.text.x=element_blank(),
          axis.ticks.x=element_blank())
}

# Return the squared error as a function of iterations.
# By default, the error is computed for each chain and then
# averaged.
# Due to dimensionality, we need to treat the case where we
# have one chain seperately.
# f specifies the functions use for the estimate (for the classic
# Monte Carlo estimate, f is the mean. Other applications include
# quantiles and probability of exceeding a threshold).
# f must specified as a vector of functions, to accomodate the
# case where we apply a different function for each parameter.
squared_error <- function(samples, benchmark, average_chain = T,
                          one_chain = F, f = c(mean)) {
  n_iter <- dim(samples)[1]
  n_chain <- dim(samples)[2]
  n_parm <- dim(samples)[3]

  if (length(f) == 1) {
    f_new <- f
    for (i in 2:n_parm) f_new <- c(f_new, f)
    f <- f_new
  }

  strat_err <- array(NA, c(n_iter, n_parm))

  for (i in 1:n_iter) {
    for (j in 1:n_parm) {
      if(!one_chain) {
        if (average_chain) {
          chain_err <- rep(NA, n_chain)
          for (k in 1:n_chain) {
            chain_err[k] <- (f[[j]](samples[1:iter[i], k, j]) - benchmark[j])^2
          }
          strat_err[i, j] <- mean(chain_err)
        } else {  # do not average chain
          strat_err[i, j] <-
            (f[[j]](samples[1:iter[i], , j]) - benchmark[j])^2
        }
      } else {  # only one chain
        strat_err[i, j] <- (f(samples[1:iter[i], j]) - benchmark[j])^2
      }
    }
  }
  strat_err
}

iteration_time <- function(fit, iter, include_warmup = F) {
  elapsed_time <- get_elapsed_time(fit)
  warmup <- mean(elapsed_time[, 1])
  sampling <- mean(elapsed_time[, 2])

  time <- (iter / max(iter)) * sampling
  if (include_warmup) time <- time + warmup
  time
}

error_plot <- function(samples_standard, samples_laplace, benchmark,
                       pars,
                       plot_time = FALSE, time_standard = NULL,
                       time_laplace = NULL, one_chain = F,
                       average_chain = T, log_parm = F,
                       f = c(mean), parm_label = NULL) {
  n_iter <- dim(samples_standard)[1]
  iter <- 1:n_iter
  n_chain <- dim(samples_standard)[2]
  n_pars <- length(pars)

  if (log_parm) {
    samples_standard <- log(samples_standard)
    samples_laplace <- log(samples_laplace)
    print("Make sure the benchmark averages the log!")
  }

  err_standard <- c(squared_error(samples_standard, benchmark, average_chain,
                                  one_chain, f = f))
  err_laplace <- c(squared_error(samples_laplace, benchmark, average_chain,
                                 one_chain, f = f))
  err <- c(err_standard, err_laplace)

  method <- rep(c("(full) HMC", "HMC + Laplace"),
                each = n_iter * n_pars)
  # TODO - if we don't average chains, iter should be iter * n_chain
  sample_size <- rep(iter, 2 * n_pars)

  parm <- rep(rep(pars, each = n_iter), 2)
  if (!is.null(parm_label)) parm <- factor(parm, label = parm_label)

  plot.data <- data.frame(err, parm, method, sample_size)

  if (!plot_time) {
    plot <- ggplot(data = plot.data, aes(x = sample_size,
                                         y = err, color = method))
  }

  if (plot_time) {
    plot.data$time <- c(rep(time_standard, length(pars)),
                        rep(time_laplace, length(pars)))
    plot <- ggplot(data = plot.data, aes(x = time, y = err, color = method))
  }

  plot <- plot + geom_line() + theme_bw() +
    facet_wrap(~parm, scale = "free", labeller = "label_parsed",
               nrow = 1)

  plot
}


## R codes for paper on catastrophic regime shifts in Sao Paulo Reservoirs
## RM Coutinho, RA Kraenkel adn PI Prado
## Encoding: UTF-8
## prado@ib.usp.br
## Fitting the stochastic models with and without effect of water volume in the reservoir
## The following code refits the model. As the fit is done with probabilistic sampling, the results may differ slightly
## The fit that we used in the paper are in stored in the file fitted_bsmc.RData
## To use this models run the first chunk below (R setup) and then
## c1y.m1 <- create.pomp.3p(cant.plos.1y)
## c1y.m0 <- create.pomp.3p.sc(cant.plos.1y)

###################################################
### R setup
###################################################
source("data_preparation.r")
source("functions.R")
## Maximum capacity of Cantareira
cant.vmax <- 1.2695e9

################################################################################
## 1. Model with effect of rain and volume
################################################################################
## pomp object of the model
c1y.m1 <- create.pomp.3p(cant.plos.1y)
## Starting values: coefs from trajectory matching
guess <- c(a0=9, a1=0.6, a3=0.59, V.0=cant.plos.1y$v.abs[1], dp=3.2e7, sigma=4e-3)
## Checking simulations with starting parameters: bad fit but not nonsense values
fc.plot(res.fc(c1y.m1, cant.plos.1y$v.abs, cant.plos.1y,
               coefs=guess, nsim=100, V.max=cant.vmax))
## BSMC ##
## Priors
c1y.prior <- function(params,...){
    params["a0"] <- runif(n=1, min=0.1, max=20)
    params["a1"] <- runif(n=1, min=0.01,max=0.99)
    params["sigma"] <- runif(n=1, min=0.001,max=0.05)
    params
}
##Fiting with bayesian filter in two steps:
c1y.bsmc <- bsmc2.fit.3p(c1y.m1, params=guess, rpriors=c1y.prior, Np=10000) %>% # 10k thousand iterations with the priors above
    bsmc2.fit.3p(c1y.m1, bsmc2.obj=., Np=30000) ## 30k iterations with lognormal priors from the previous fit
save.image()
## Plausibility intervals of predicted trajectories ##
## With coefficient combinations sampled from posterior distributions
## Trajectories bounded within 0 to maximum volume
c1y.m1.fit <- res.fc(c1y.m1, cant.plos.1y$v.abs, cant.plos.1y,
                           coefs=exp(c1y.bsmc@post),
                     nsamp.coef=5000, nsim=1, V.max=cant.vmax, states=FALSE)
## Quick check
fc.plot(c1y.m1.fit)

################################################################################
## 2. Model with effect of rain only
################################################################################
## pomp object of the model
c1y.m0 <- create.pomp.3p.sc(cant.plos.1y)
## Starting values: coefs from trajectory matching
guess2 <- c(a0=9e5, a1=0.3, V.0=cant.plos.1y$v.abs[1], dp=3.2e7, sigma=4e-3)
## Check simulations with starting parameters
fc.plot(res.fc(c1y.m0, cant.plos.1y$v.abs, cant.plos.1y,
       coefs=guess, nsim=100, V.max=cant.vmax))
## BSMC ##
## Priors
c1y.prior2 <- function(params,...){
    params["a0"] <- runif(n=1, min=1e5, max=1e7)
    params["a1"] <- runif(n=1, min=0.01,max=0.99)
    params["sigma"] <- runif(n=1, min=0.001,max=0.05)
    params
}
##Fiting with bayesian filter in two steps:
c1y.bsmc2 <- bsmc2.fit.3p(c1y.m0, params=guess2, rpriors=c1y.prior2, Np=10000) %>% # 10k iterations with the priors above
    bsmc2.fit.3p(c1y.m0, bsmc2.obj=., Np=30000) # 30k iterations with lognormal priors from the previous fit
save.image()
## Plausibility intervals of predicted trajectories ##
## With coefficient combinations sampled from posterior distributions
## Trajectories bounded within 0 to maximum volume
c1y.m0.fit <- res.fc(c1y.m0, cant.plos.1y$v.abs, cant.plos.1y,
                           coefs=exp(c1y.bsmc2@post),
                     nsamp.coef=5000, nsim=1, V.max=cant.vmax, states=FALSE)
## Quick check
fc.plot(c1y.m0.fit)

## Model comparison: log-likelihoods
LL1 <- c1y.bsmc@log.evidence
LL0 <- c1y.bsmc2@log.evidence
LL1 - LL0

## Saves fitted models and simulated intervals
save(c1y.bsmc, c1y.bsmc2, c1y.m0.fit, c1y.m1.fit, file="fitted_bsmc.Rdata")


# script for cv mortality
# extract the data from the information
# save the datasets after combining the data.

library("tidyverse")
library("survival")
library("IPDfromKM")
library("metaRMST")
library("broom")
library("survminer")

# get the data 1 trial at a time and then format it to extract information.

# leader
# liraglutide arm -

li <- read.table("F:/GLP1_agonists/data/leader/cvmort_liraglutide.txt")

summary(li)

# convert V2 to survival -

li$V2 <- with(li, ifelse(V2 == -0.0479, 0, V2))

li$V2 <- 100 - li$V2

li$V2 <- with(li, ifelse(V2 > 100, 100, V2))

summary(li)

# now to extract information

nrisk_l <- c(4668, 4641, 4599, 4558, 4505, 4445, 4382, 4322, 1723, 484)

trisk_l <- c(0,6, 12, 18, 24, 32, 36, 42, 48, 54)

leader_l <- preprocess(dat = li,
                             trisk = trisk_l,
                             nrisk = nrisk_l,
                             maxy = 100)

leader_ipd_li <- getIPD(prep = leader_l,
                             armID = 1)

plot(leader_ipd_li)

cv_mort_li <- leader_ipd_li$IPD

# control arm

control <-
read.table("F:/GLP1_agonists/data/leader/cvmort_control.txt")

summary(control)

# convert V2 to survival -

control$V2 <- 100 - control$V2

summary(control)

# now to extract information

nrisk_c <- c(4672, 4648, 4601, 4479, 4407, 4338, 4267, 1709, 465)

trisk_c <- c(0,6, 12, 18, 24, 32, 36, 42, 48, 54)

leader_c <- preprocess(dat = control,
                       trisk = trisk_c,
                       nrisk = nrisk_c,
                       maxy = 100)

leader_ipd_c <- getIPD(prep = leader_c,
                        armID = 0)

plot(leader_ipd_c)

cvmort_control <- leader_ipd_c$IPD

# combine data and then plot

df_leader_cvmort <- rbind(cv_mort_li, cvmort_control)

cvmort_leader_s <-
  survfit(Surv(time, status) ~ treat, data = df_leader_cvmort)

ggsurvplot(cvmort_leader_s,
           fun = "event",
           ylim = c(0,0.20),
           xlim = c(0,54),
           break.x.y = 6,
           break.y.by = 0.05,
           censor.size = 0,
           palette = c("gray","blue2"))

# time already in months.

write_csv(df_leader_cvmort,
  'F:\\GLP1_agonists\\data\\pooled_data\\cvmort_leader.csv'
)

# sustain 6

sema <- read.table("F:/GLP1_agonists/data/sustain6/cvmort_semaglutide.txt")

summary(sema)

# convert V2 to survival -

sema$V2 <- 100 - sema$V2

summary(sema)

# now to extract information

nrisk_s <- c(1648, 1634, 1627, 1617, 1607, 1589, 1579)

trisk_s <- c(0,16, 32, 48, 64, 80, 96)

sustain6_s <- preprocess(dat = sema,
                       trisk = trisk_s,
                       nrisk = nrisk_s,
                       maxy = 100)

sustain6_ipd_sema <- getIPD(prep = sustain6_s,
                        armID = 1)

plot(sustain6_ipd_sema)

cv_mort_sema <- sustain6_ipd_sema$IPD

# now to get control arm data

control <-
read.table("F:/GLP1_agonists/data/sustain6/cvmort_control.txt")

summary(control)

# convert V2 to survival -

control$V2 <- 100 - control$V2

summary(control)

# now to extract information

nrisk_c <- c(1649, 1637, 1623, 1617, 1600, 1584, 1566)

trisk_c <- c(0,16, 32, 48, 64, 80, 96)

sustain6_c <- preprocess(dat = control,
                         trisk = trisk_c,
                         nrisk = nrisk_c,
                         maxy = 100)

sustain6_ipd_control <- getIPD(prep = sustain6_c,
                            armID = 0)

plot(sustain6_ipd_control)

cv_mort_control <- sustain6_ipd_control$IPD

# combine the dataset and then plot again

cvmort_sustain6 <- rbind(cv_mort_sema, cv_mort_control)

surv_sustain6 <- survfit(Surv(time, status) ~ treat,
                         data = cvmort_sustain6)

# plot graph

ggsurvplot(surv_sustain6,
           data = cvmort_sustain6,
           fun = "event",
           ylim = c(0,0.05),
           break.y.by = 0.01,
           xim = c(0, 104),
           break.x.by = 8,
           palette = c("gray","blue2"),
           censor.size = 0)

# now to convert weeks to months
# save with time in months

cvmort_sustain6$time <- cvmort_sustain6$time/4

# save dataaset

write_csv(cvmort_sustain6,
  'F:\\GLP1_agonists\\data\\pooled_data\\cvmort_sustain6.csv')

# EXCSEL

exe <-
read.table("F:/GLP1_agonists/data/excsel/cvmort_exenatide.txt")

summary(exe)

# convert V2 to survival -

exe$V2 <- 100 - exe$V2

summary(exe)

# now to extract information

nrisk_e <- c(7356, 7234, 6433, 4095, 2698, 892)

trisk_e <- c(0,1,2,3,4,5)

excsel_exe <- preprocess(dat = exe,
                         trisk = trisk_e,
                         nrisk = nrisk_e,
                         maxy = 100)

excsel_ipd_exe <- getIPD(prep = excsel_exe,
                            armID = 1)

plot(excsel_ipd_exe)

cv_mort_exe <- excsel_ipd_exe$IPD

# control arm of EXCSEL

control <-
  read.table("F:/GLP1_agonists/data/excsel/cvmort_control.txt")

summary(control)

# convert V2 to survival -

control$V2 <- 100 - control$V2

summary(control)

# now to extract information

nrisk_c <- c(7396, 7278, 6470, 4091, 2666, 907)

trisk_c <- c(0,1,2,3,4,5)

excsel_c <- preprocess(dat = control,
                         trisk = trisk_c,
                         nrisk = nrisk_c,
                         maxy = 100)

excsel_ipd_c <- getIPD(prep = excsel_c,
                         armID = 0)

plot(excsel_ipd_c)

cv_mort_control <- excsel_ipd_c$IPD

# combine dataset and then plot

cvmort_excsel <- rbind(cv_mort_exe, cv_mort_control)

cvmort_excsel_s <- survfit(Surv(time, status) ~ treat,
                           data = cvmort_excsel)

ggsurvplot(cvmort_excsel_s,
           data = cvmort_excsel,
           xlim = c(0,5),
            ylim = c(0,0.18),
            break.y.by = 0.03,
           censor.size = 0,
          fun = "event",
          palette = c("blue","red"),
          linetype = c(2,1))

# convert time to months
# save dataset

cvmort_excsel$time <- cvmort_excsel$time*12

write_csv(cvmort_excsel,
  'F:\\GLP1_agonists\\data\\pooled_data\\cvmort_excsel.csv'
)

# Harmony Outcomes

albi <-
  read.table("F:/GLP1_agonists/data/Harmony/cvmort_albiglutide.txt")

summary(albi)

# convert V2 to survival -

albi$V2 <- 100 - albi$V2

summary(albi)

# now to extract information

nrisk_a <- c(4731, 4681, 4611, 4379, 3274, 2234, 1121)

trisk_a <- c(0, 4, 8, 12, 16, 20, 24 )

harmony_a <- preprocess(dat = albi,
                         trisk = trisk_a,
                         nrisk = nrisk_a,
                         maxy = 100)

harmony_ipd_a <- getIPD(prep = harmony_a,
                         armID = 1)

plot(harmony_ipd_a)

cv_mort_albi <- harmony_ipd_a$IPD

# control arm in Harmony Outcomes

control <-
read.table("F:/GLP1_agonists/data/Harmony/cvmort_control.txt")

summary(control)

# convert V2 to survival -

control$V2 <- 100 - control$V2

summary(control)

# now to extract information

nrisk_c <- c(4732, 4662, 4580, 4373, 3245, 2261, 1121)

trisk_c <- c(0, 4, 8, 12, 16, 20, 24 )

harmony_c <- preprocess(dat = control,
                        trisk = trisk_c,
                        nrisk = nrisk_c,
                        maxy = 100)

harmony_ipd_c <- getIPD(prep = harmony_c,
                        armID = 0)

plot(harmony_ipd_c)

cv_mort_harmony_c <- harmony_ipd_c$IPD

# combine dataasets

cvmort_harmony <- rbind(cv_mort_albi, cv_mort_harmony_c)

cvmort_hs <- survfit(Surv(time, status) ~ treat,
                     data = cvmort_harmony)

ggsurvplot(
  cvmort_hs,
  data = cvmort_harmony,
  fun = "event",
  xlim = c(0,28),
  ylim = c(0, 0.18),
  break.y.by = 0.02,
  break.x.by = 4,
  censor.size = 0,
  palette = c("blue2","red")
)

# convert time to months from weeks

cvmort_harmony$time <- cvmort_harmony$time*4

write_csv(
  cvmort_harmony,
  'F:\\GLP1_agonists\\data\\pooled_data\\cvmort_harmony.csv'
)

# REWIND

dula <-
read.table("F:/GLP1_agonists/data/rewind/cvmort_dulaglutide.txt")

summary(dula)

dula$V1 <- with(dula, ifelse(V1 < 0, 0 , V1))

dula$V2 <- with(dula, ifelse(V2 < 0, 0, V2))

# convert V2 to survival -

dula$V2 <- 100 - dula$V2

summary(dula)

# now to extract information

nrisk_d <- c(4949, 4866, 4773, 4663, 4556, 3887, 807)

trisk_d <- c(0, 1, 2, 3, 4, 5, 6)

rewind_d <- preprocess(dat = dula,
                        trisk = trisk_d,
                        nrisk = nrisk_d,
                        maxy = 100)

rewind_ipd_d <- getIPD(prep = rewind_d,
                        armID = 1)

plot(rewind_ipd_d)

cvmort_rewind_d <- rewind_ipd_d$IPD

# control arm of rewind

control <-

read.table(
  "F:/GLP1_agonists/data/rewind/cvmort_control.txt"
)

summary(control)

control$V1 <- with(control, ifelse(V1 < 0, 0 , V1))

# convert V2 to survival -

control$V2 <- 100 - control$V2

summary(control)

# now to extract information

nrisk_c <- c(4952, 4854, 4748, 4617, 4499, 3813, 802)

trisk_c <- c(0, 1, 2, 3, 4, 5, 6)

rewind_c <- preprocess(dat = control,
                       trisk = trisk_c,
                       nrisk = nrisk_c,
                       maxy = 100)

rewind_ipd_c <- getIPD(prep = rewind_c,
                       armID = 0)

plot(rewind_ipd_c)

cvmort_rewind_c <- rewind_ipd_c$IPD

# combine dataset

cvmort_rewind <- rbind(cvmort_rewind_d, cvmort_rewind_c)

# create survobject and plot

cvmort_rewind_s <- survfit(Surv(time, status) ~ treat,
                           data = cvmort_rewind)

plot(cvmort_rewind_s)

ggsurvplot(cvmort_rewind_s,
           data = cvmort_rewind,
           fun = "event",
           ylim = c(0, 0.18),
           censor.size = 0,
           break.y.by = 0.03)

# convert years to months

cvmort_rewind$time <- cvmort_rewind*12

write_csv(
  cvmort_rewind,
  'F:\\GLP1_agonists\\data\\pooled_data\\cvmort_rewind.csv'
)

# PIONEER 6

psema <-
  read.table(
    "F:/GLP1_agonists/data/pioneer6/cvmort_semaglutide.txt")

summary(psema)

psema$V1 <- with(psema, ifelse(V1 < 0, 0, V1))

psema$V2 <- with(psema, ifelse(V2 < 0, 0, V2))

# convert V2 to survival -

psema$V2 <- 100 - psema$V2

summary(psema)

# now to extract information

pioneer6_sema <- preprocess(dat = psema,
                            totalpts = 1591,
                         maxy = 100)

pioneer6_ipd_sema <- getIPD(prep = pioneer6_sema,
                         armID = 1)

plot(pioneer6_ipd_sema)

cvmort_pioneer6_sema <- pioneer6_ipd_sema$IPD

# control arm for pioneer6

p_control <-
  read.table(
    "F:/GLP1_agonists/data/pioneer6/cvmort_control.txt")

summary(p_control)

p_control$V1 <- with(p_control, ifelse(V1 < 0, 0, V1))

# convert V2 to survival -

p_control$V2 <- 100 - p_control$V2

summary(p_control)

# now to extract information

pioneer6_control <- preprocess(dat = p_control,
                            totalpts = 1592,
                            maxy = 100)

pioneer6_ipd_control <- getIPD(prep = pioneer6_control,
                            armID = 0)

cvmort_pioneer6_control <- pioneer6_ipd_control$IPD

cvmort_pioneer6 <- rbind(cvmort_pioneer6_sema, cvmort_pioneer6_control)

# plot graph

cvmort_pioneer6_s <- survfit(Surv(time, status) ~ treat,
                             data = cvmort_pioneer6)

ggsurvplot(cvmort_pioneer6_s,
           data = cvmort_pioneer6,
           xlim = c(0, 83),
           ylim = c(0, 0.1),
           break.x.by = 9,
           break.y.by = 0.01,
           censor.size = 0,
           palette = c("gray","blue2"),
          fun = "event")

# convert weeks to months
# save combined dataset

cvmort_pioneer6$time <- cvmort_pioneer6$time/4

write_csv(cvmort_pioneer6,
          'F:\\GLP1_agonists\\data\\pooled_data\\cvmort_pioneer6.csv')


install.packages(c("arules", "arulesViz"))
library(arules)
library(arulesViz)
data(Groceries)
data(Adult)

# Zadatak 1
itemsets <- apriori(Groceries, parameter = list(minlen=1, maxlen=1, support=0.15, target="frequent itemsets"))
inspect(sort(itemsets, by="support"))
# Svi proizvodi imaju minumalno 0.15 support

# Zadatak 2
# a
itemsets2 <- apriori(Groceries, parameter = list(minlen=2, maxlen=2, support=0.03, target="frequent itemsets"))
inspect(sort(itemsets2, by="support"))
# 19 item setova zadrzi dva proizvoda i minimalni support iznosi 0.03
# b
plot(itemsets2, method="graph", control=list(type="items"))
# Plot predstavlja veze izmedu pojedinih proizvoda, s kojim se artiklom koji artikal najcesce pojavljuje

# Zadatak 3
# a
itemsets3 <- eclat(Adult, parameter = list(supp = 0.7, minlen = 3))
inspect(sort(itemsets3, by="support"))
# Napravljena su 4 item seta
# b
plot(itemsets3, method="graph", control=list(type="items"))