# This is adapted from the code in http://goo.gl/zw2eeq
# It has been edited for clarity and style, and comments have been added.
# This version is for math only

# Arguments:
# item_parameters_file: a csv of items and their parameters that
#   we'll optimize over
# content_minimums: A list with the minimum values for each content category
#   The content categories should be named 1 - n, with each item in
#   content_minimums corresponding to the corresponding category.
# num_forms: an int representing the total number of forms we're creating
# items_per_form: an int representing the number of items per form
solver <- function(item_parameters_file, content_minumums, num_forms, n){

    # Constants
    # These are the ability  values for which we care about maximizing the TIF
    theta = c(-1.5,0,1.5);
    # These are target information levels for the three ability levels we're
    # optimizing for in our optimization function
    d_theta = c(5.4, 10, 5.4);

    # Manually set constants end here!

    # Import the lpsolve library
    library(lpSolveAPI);

    # Read in the data. This should be of the form item,a,b,c,category
    # This example involves IRT for the Test Information Function
    s = read.csv(item_parameters_file);

    # The 3PL model for items has these three variables, a, b, and c. Learn more
    # on wikipedia: http://en.wikipedia.org/wiki/Item_response_theory

    # a is discrimination
    a = s$a;

    # b is difficulty
    b = s$b;

    # c is a psudo-guessing offset
    c = s$b;

    # Content is the different categories - like 1, 2, 3, 4, 5, 6...
    content = s$Content;

    # i is just the total number of items
    num_items = nrow(s);

    # This is the number of content categories. We assume they're labeled
    # 1-num_categories for the sake of simplicity
    num_categories = length(unique(content));

    # This is where we sort all of our items by content.
    content_items=list();
    for(k in 1:num_categories){
        content_items[[k]] = c(1:num_items)[content==k];
    }

    # This i x j array contains the amount of information item i gives us
    # about theta value j
    j=length(theta);
    info = array(0,c(num_items, j));

    # This calculates the information at each value
    # http://en.wikipedia.org/wiki/Item_response_theory#Three_parameter_logistic_model
    # euler's constant, e, can be represented as exp(1)
    e = exp(1)
    for (jj in 1:j){
        # P is the probability of answering correctly
        p = c + (1-c) / (1 + exp(-e * a * (theta[jj]-b)));
        q = 1 - p;

        # src:de Ayala, R.J. (2009). The Theory and Practice of Item Response
        # Theory, New York, NY: The Guilford Press. (6.12), p.144
        info[,jj] = (e^2) * (a^2) * ((p - c)/(1 - c))^2 * q / p;
    }

    # m is the total number of decision variables. We're deciding whether each item
    # is in each form, so we have i * f variables. (TODO: What is the last one)
    m = num_items * num_forms + 1;

    # CONFIGURE THE LINEAR PROGRAM

    # Here's our linear program object
    # We start with 0 rows and m columns. Rows are added as constraints are added.
    lprec = make.lp(0, m);

    # The sense control means we're minimizing the objective function
    # epsint is the tolerance to decide if a floating point number is an integer
    # The mip gap has to do with the algorithm used and what solution branches to
    # ignore to speed things up.
    # See http://lpsolve.sourceforge.net/5.5/set_mip_gap.htm
    lp.control(lprec, sense="min", epsint=0.1, mip.gap = c(0.1,0.05));

    # All of the first i * f columns are binary, as they represent whether each
    # item is in each form
    set.type(lprec, columns=c(1:(num_forms * num_items)), type="binary");

    # The last decision variable is real
    set.type(lprec, columns=m, type="real");

    # Each variable must range between 0 and 1
    set.bounds(lprec, lower=rep(0, m), upper=rep(1, m));

    # ADD CONSTRAINTS TO THE LINEAR PROGRAM

    # This adds a constraint that each item can only exist in one form.
    # This actually will only work for two forms max.
    # It's basically guaranteeing that an array of ones times an array of
    # whether item i appears in form f for each i and all f is <= 1.
    for (i in 1:num_items){

        idxs = c();
        for (f in 1:num_forms){
            item_offset = num_items * (f - 1);
            idxs = c(idxs, i + item_offset);
        }
        add.constraint(lprec, rep(1, num_forms), "<=", 1, indices=idxs);
    }

    # Add constraints on the amount of content in each category
    for (f in 1:num_forms)
    {
        item_offset = num_items * (f - 1);
        for (k in 1:length(content_minumums)) {
            add.constraint(
                lprec,
                rep(1, length(content_items[[k]])), ">=", content_minumums[k],
                indices=item_offset + content_items[[k]]);
        }
    }

    # Ensure there are exactly n items in each form
    for (f in 1:num_forms)
    {
        first_item = num_items * (f - 1) + 1;
        last_item = num_items * f;
        add.constraint(lprec,
                       rep(1, num_items), "=", n,
                       indices=first_item:last_item);
    }

    # Add constraints on the information level
    for (f in 1:num_forms)
    {
        first_item = num_items * (f - 1) + 1;
        last_item = num_items * f;

        # Add a constraint for each theta level
        for (k in 1:length(d_theta)) {
            add.constraint(lprec,
                           c(info[,k], -1), "<=", d_theta[k],
                           indices=c(first_item:last_item,m));
            add.constraint(lprec,
                           c(info[,k], 1), ">=", d_theta[k],
                           indices=c(first_item:last_item,m));

        }
    }

    # Set the objective function
    set.objfn(lprec, 1, indices=m);

    res_flag = solve(lprec);

    res_flag;

    # Now x_opt contains the assignments of questions to forms
    # TODO: Print out an understandable list of Form #, Item #
    x_opt = get.variables(lprec);

    return(x_opt);
}


#building uncertainty products for NEON soils data where available.
#clear environment, load paths.
rm(list=ls())
source('paths.r')
library(runjags)
#load data.
dp1.10078 <- readRDS(dp1.10078.00_output.path)

#variable generating ucnertainty for.
of_interest <- 'organicCPercent'
#set output path.
output.path <- pC_NEON_uncertainty_model.path

#organize analysis product.----
#grab within core replicated observations.
duped <- dp1.10078[duplicated(dp1.10078$sampleID),]
duped <- dp1.10078[dp1.10078$sampleID %in% duped$sampleID,]
duped <- duped[,c('sampleID',of_interest)]
#take core-level means.
to_ag <- aggregate(duped[,c(of_interest)] ~ sampleID, data = duped, FUN = mean)
colnames(to_ag)[2] <- 'mean'
to_analyze <- merge(to_ag, duped[,c('sampleID',of_interest)], all.y=T)
colnames(to_analyze)[3] <- 'obs'
to_analyze <- to_analyze[complete.cases(to_analyze),]
plot(obs ~ mean, data = to_analyze)

#jags model.----
jags.model = "
model {
#prior on relationship between mean and observed pC values.
#preliminary analysis says this is slope of 1, intercept of zero, as it should be. Not fitting an intercept.
m ~ dnorm(0, .0001) #flat uninformative priors.

#magnitude of %C observation affects uncertainty.
#tau is still a function of sigma.
#sigma is now a funtion of an intercept (as before) and magnitude of C observation, with a parameter that gets fitted.
#interval censored. variances cannot be zero.
k0 ~ dnorm(0,1E-3) I(0,)
k1 ~ dnorm(0,1E-3) I(0,)

#fit a linear model. x is mean C for an observation, y is observed.
for(i in 1:N){
y.hat[i] <-  m*x[i]
sigma[i] <- k0 + k1*x[i]
tau[i] <- pow(sigma[i], -2)
y[i] ~ dnorm(y.hat[i], tau[i])
}
} #close model loop.
"
#specify jags data object and fit.----
jd <- list(y=to_analyze$obs, x=to_analyze$mean, N = nrow(to_analyze))
library(runjags)
fit  <- run.jags(model = jags.model,
                 data = jd,
                 adapt = 200,
                 burnin = 2000,
                 sample = 3000,
                 monitor = c('m','k0','k1'),
                 n.chains = 3)
out <- summary(fit)

#Save output.
saveRDS(out,output.path)


library(tidyverse) # data cleaning
library(sf) # spatial functions
library(here)
library(sp)

#function for getting data.
get_data <- function(type ="fixed", year = "2020", quarter = "1"){
  temp <- tempfile()
  temp2 <- tempfile()

  #customise file name based on parameters of data set
  if(quarter==1){
    filedate <- paste0(year, "-01-01")
  }else if(quarter==2){
    filedate <- paste0(year, "-04-01")
  }else if(quarter==3){
    filedate <- paste0(year, "-07-01")
  }else if(quarter==4){
    filedate <- paste0(year, "-10-01")
  }else{
    print("Error - filedate not set")
  }

  path = paste0("https://ookla-open-data.s3-us-west-2.amazonaws.com/shapefiles/performance/type%3D", type, "/year%3D", year, "/quarter%3D", quarter, "/", filedate, "_performance_", type, "_tiles.zip")

  ## download the zip folder from s3 and save to temp
  download.file(path,temp)

  unzip(zipfile = temp, exdir = temp2)
  ## finds the filepath of the shapefile (.shp) file in the temp2 unzip folder
  ## the $ at the end of ".shp$" ensures you are not also finding files such as .shp.xml
  shp <- read_sf(list.files(temp2, pattern = ".shp$",full.names=TRUE))

  # create a bounding box for Wales
  wales_bbox = st_as_sfc(st_bbox(c(xmin = -5.7, ymin = 51.35, xmax = -2.66, ymax = 53.5), crs = st_crs(shp)))

  #get all the tiles that intersect with the bounding box
  tiles_in_bbox <- st_intersects(wales_bbox, shp)

  #filter for the tiles that intersect with Wales
  shp_wales <- shp[tiles_in_bbox[[1]],]

  #write the data to the data folder with customised filenames
  write_sf(shp_wales, paste0("./data/y-", year, "-q", quarter, "-type-", type, ".shp"))

}


# Figure 2: Density Plot of Predicted Probability
# Conservative For Different Levels of Noise.

rm(list=ls())
library(ggplot2)
library(reshape2)

wd <- getwd()
data.dir <- paste0(wd, "/data/")
df <- read.csv(paste0(data.dir, "preds_sims_sel.csv"), header=T)

m <- melt(df, id.vars='noisefrac')

m$party <- sapply(m$variable, substring, 1,1)
m$party[m$party=='r'] <- 'Right'
m$party[m$party=='l'] <- 'Left'

left <- m[m$party=='Left',]
right <- m[m$party=='Right',]

p <- ggplot(m, aes(value, linetype=as.factor(noisefrac)))
p +  geom_density() + theme_bw() + xlim(0,1)+labs(linetype = "Fraction Noise") + xlab("Predicted Probability Conservative") + ylab("density")
ggsave("density_by_noise.pdf",  width=10, height=6)
dev.off()


library(Rcpp)
library(dplyr)
library(ggplot2)

init_solver <- function() {
    # Set system variable for the compiler, so that it
    # can find external librarys and header files.
    Sys.setenv("PKG_CXXFLAGS"="-I/D:\\Dokumente\\C++\\Includes")

    print("Compling files...")

    # Start the clock.
    ptm <- proc.time()

    # Compile the C++ Source file with the main function.
    sourceCpp("R Shiny Webapp\\solver_main.cpp")

    # Stop the clock and print it to console.
    print(proc.time() - ptm)
    print("Done compling!")
}

mesh_rplot <- function(x, y, ux, uy, scale_factor) {
    # Create empty plot.
    plot(-5:5,-5:5,type='n')

    # Add polygons to the plot for each element.
    node_index <- 1
    element_nodes_global <- character()

    for (element in 1:(length(x)/3) ) {
        # Put the node coordinates (xx, yy) to one element (= triangle) in one list.
        # Mesh data.
        element_nodes_local_xy <- list(xx=c(x[node_index], x[node_index + 1], x[node_index + 2]),
                                    yy=c(y[node_index], y[node_index + 1], y[node_index + 2]))

        # Mesh data + scale_factor * displacement.
        element_nodes_local_uxuy <- list(xx=c(x[node_index] + scale_factor * ux[node_index],
                                            x[node_index + 1] + scale_factor * ux[node_index + 1],
                                            x[node_index + 2] + scale_factor * ux[node_index + 2]),
                                        yy=c(y[node_index] + scale_factor * uy[node_index],
                                            y[node_index + 1] + scale_factor * uy[node_index + 1],
                                            y[node_index + 2] + scale_factor * uy[node_index + 2]))

        node_index <- node_index + 3

        # Draw pologons for each element. First mesh, then mesh + displacement.
        polygon(element_nodes_local_xy$xx, element_nodes_local_xy$yy, col="gray", border="blue")
        polygon(element_nodes_local_uxuy$xx, element_nodes_local_uxuy$yy, col="gray", border="red")
    }
}

mesh_ggplot <- function(x, y, ux, uy, stress) {
    # See https://ggplot2.tidyverse.org/reference/geom_polygon.html for info
    # on polygon plots with ggpolt2.
    element_count <- length(x)/3

    # Create an unique ID for every element to match the data later.
    ids <- 1:element_count

    # Stress values to color the elements.
    values <- data.frame(
        id = ids,
        value = stress
    )

    # Coordinates of the nodes.
    positions <- data.frame(
        id = rep(ids, each = 3),
        xx = x,
        yy = y,
        uxx = x + ux,
        uyy = y + uy
    )

    # Match the data of the stress values and the positions using the ID.
    poly_data <- merge(values, positions, by = c("id"))

    # Plot the mesh data.
    p <- ggplot() +
        geom_polygon(data = poly_data, aes(x = xx, y = yy, fill = value, group = id), colour = "black") +
        geom_polygon(data = poly_data, aes(x = uxx, y = uyy, fill = value, group = id), colour = "black") +
        xlim(-5, 5) +
        ylim(-5, 5) +
        scale_fill_gradient(low="blue", high="red")

    return(p)
}

# Compile the C++ source and run the solver.
#init_solver()

# Call C++ functions form the compiled source to calculate all
# the displacements from the provided input file which contains
# the mesh data.
#displacements = solve_linear_elastic("D:\\Dokumente\\GitHub\\2D-FEM-Solver\\R Shiny Webapp\\Mesh_Balken_V2.txt")
#mises_stresses = output_mises_stress()

# Reshape data.
#x <- unname(sapply(displacements, `[[`, 1))
#y <- unname(sapply(displacements, `[[`, 2))
#ux <- unname(sapply(displacements, `[[`, 3))
#uy <- unname(sapply(displacements, `[[`, 4))

# Plot mesh and mesh + displacement with standard r plot.
#mesh_rplot(x, y, ux, uy, 1)

# Plot contur of mesh + stress wwith ggpolt2.
#print(mesh_ggplot(x, y, ux, uy, mises_stresses))


#!/usr/bin/env Rscript

data = read.csv("hw1_data.csv")
isJune = data[['Month']] == 6
mean(data[isJune,][['Temp']])


args <- commandArgs(trailingOnly = TRUE)
intab <- args[1]

#normalize data first => filter all zero, add min, log2, quantile?
data=read.table(intab, sep="\t", header=TRUE, row.names=1)

c=cor(data, method="spearman") #pearson is default, use spearman to match ENCODE
data=as.matrix(data)
data=as.numeric(data)

cr=round(c, digits=2)
library("gplots")
library("RColorBrewer")
my_palette <- c("#1000FFFF","#0047FFFF","#00C8FFFF","#00FFE0FF","#00FF89FF","#00FF33FF","#99FF00FF","#AFFF00FF","#FFD800FF","#FFB800FF","#FFAD00FF","#FF8100FF","#FF5600FF","#FF2B00FF","#FF0000FF")

#breaks for RNA
breaks = c(seq(.7,1,.02))
dist.pear <- function(x) as.dist(1-x)
heatmap.2(c, dendrogram="row", col=my_palette, breaks=breaks, trace="none", revC=TRUE, symm=TRUE, distfun=dist.pear, symkey=FALSE, keysize=1.3, key.title=NA, key.par=list(cex=1))

q()


# clean environment
rm(list = ls())

# set directory
wd <- "C:/Users/gbal/Desktop/r.training/3.code"
setwd(wd)

# create data for example ==================================================

# new folder to store things
new.folder <- 'excel.vs.r'
dir.create(new.folder)

# create random matrices and save them
n.matrices <- 100
for(m in 1:n.matrices){
  n.cols <- sample(size = 1, 10:100)
  n.rows <- sample(size = 1, 10:100)
  new.matrix <- matrix(round(rnorm(n = n.rows * n.cols, mean = 5, sd = 2), 2),
                       nrow = n.rows,
                       ncol = n.cols)
  write.table(new.matrix, file = paste0(new.folder, '/matrix.', m, '.txt'))
}

# calculate mean per column for file ! =======================================

# file location
file.loc <- "C:/Users/gbal/Desktop/r.training/3.code/excel.vs.r/matrix.1.txt"

# load file
data.1 <- read.table(file = file.loc)

#compute mean per columns
apply(X = data.1, MARGIN = 1, FUN = mean)

# mean per colums for each file and store ====================================

# time start part of script
time.start <- Sys.time()

# location files
wd.files <-  "C:/Users/gbal/Desktop/r.training/3.code/excel.vs.r"

# get list of files
list.files <- dir(wd.files)

# create list to store mean
means.list <- list()

# fill list
for(i in 1:length(list.files)){
#i <- 1
  file.name <- paste0(wd.files, '/',list.files[i])
  data <- read.table(file.name)
  dim(data)
  mean.c <- apply(data,
                 2,
                 mean)
  means.list[[list.files[i]]] <- mean.c

}

# from list to matrix,  complicated because vector of different lengthes
means.matrix <- sapply(means.list, '[', seq(max(lengths(means.list))))

# store matrix
write.table(means.matrix, file = 'means.matrix.txt')

# time end
time.end <- Sys.time()

# duration script
difftime(time.end, time.start)

# suppress things
file.remove('means.matrix.txt')

# suppress data directory
unlink(wd.files, recursive = TRUE)


#' Decision curve analysis
#' @export
#'
dca <- function(data, outcome, predictors, xstart=0.01, xstop=0.99, xby=0.01,
  ymin=-0.05, probability=NULL, harm=NULL,graph=TRUE, intervention=FALSE,
  interventionper=100, smooth=FALSE,loess.span=0.10) {

  # data MUST BE A DATA FRAME
  if (class(data)!="data.frame") {
      stop("Input data must be class data.frame")
  }

  #ONLY KEEPING COMPLETE CASES
  data=data[complete.cases(data[append(outcome,predictors)]),append(outcome,predictors)]

  # outcome MUST BE CODED AS 0 AND 1
  if (max(data[[outcome]])>1 | min(data[[outcome]])<0) {
    stop("outcome cannot be less than 0 or greater than 1")
  }
  # xstart IS BETWEEN 0 AND 1
  if (xstart<0 | xstart>1) {
    stop("xstart must lie between 0 and 1")
  }

  # xstop IS BETWEEN 0 AND 1
  if (xstop<0 | xstop>1) {
    stop("xstop must lie between 0 and 1")
  }

  # xby IS BETWEEN 0 AND 1
  if (xby<=0 | xby>=1) {
    stop("xby must lie between 0 and 1")
  }

  # xstart IS BEFORE xstop
  if (xstart>=xstop) {
    stop("xstop must be larger than xstart")
  }

  #STORING THE NUMBER OF PREDICTORS SPECIFIED
  pred.n=length(predictors)

  #IF probability SPECIFIED ENSURING THAT EACH PREDICTOR IS INDICATED AS A YES OR NO
  if (length(probability)>0 & pred.n!=length(probability)) {
    stop("Number of probabilities specified must be the same as the number of predictors being checked.")
  }

  #IF harm SPECIFIED ENSURING THAT EACH PREDICTOR HAS A SPECIFIED HARM
  if (length(harm)>0 & pred.n!=length(harm)) {
    stop("Number of harms specified must be the same as the number of predictors being checked.")
  }

  #INITIALIZING DEFAULT VALUES FOR PROBABILITES AND HARMS IF NOT SPECIFIED
  if (length(harm)==0) {
    harm=rep(0,pred.n)
  }
  if (length(probability)==0) {
    probability=rep(TRUE,pred.n)
  }

  #CHECKING THAT EACH probability ELEMENT IS EQUAL TO YES OR NO,
  #AND CHECKING THAT PROBABILITIES ARE BETWEEN 0 and 1
  #IF NOT A PROB THEN CONVERTING WITH A LOGISTIC REGRESSION
  for(m in 1:pred.n) {
    if (probability[m]!=TRUE & probability[m]!=FALSE) {
      stop("Each element of probability vector must be TRUE or FALSE")
    }
    if (probability[m]==TRUE & (max(data[predictors[m]])>1 | min(data[predictors[m]])<0)) {
      stop(paste(predictors[m],"must be between 0 and 1 OR sepcified as a non-probability in the probability option",sep=" "))
    }
    if(probability[m]==FALSE) {
      model=NULL
      pred=NULL
      model=glm(data.matrix(data[outcome]) ~ data.matrix(data[predictors[m]]), family=binomial("logit"))
      pred=data.frame(model$fitted.values)
      pred=data.frame(pred)
      names(pred)=predictors[m]
      data=cbind(data[names(data)!=predictors[m]],pred)
      print(paste(predictors[m],"converted to a probability with logistic regression. Due to linearity assumption, miscalibration may occur.",sep=" "))
    }
  }

  # THE PREDICTOR NAMES CANNOT BE EQUAL TO all OR none.
  if (length(predictors[predictors=="all" | predictors=="none"])) {
    stop("Prediction names cannot be equal to all or none.")
  }

  #########  CALCULATING NET BENEFIT   #########
  N=dim(data)[1]
  event.rate=colMeans(data[outcome])

  # CREATING DATAFRAME THAT IS ONE LINE PER THRESHOLD PER all AND none STRATEGY
  nb=data.frame(seq(from=xstart, to=xstop, by=xby))
  names(nb)="threshold"
  interv=nb

  nb["all"]=event.rate - (1-event.rate)*nb$threshold/(1-nb$threshold)
  nb["none"]=0

  # CYCLING THROUGH EACH PREDICTOR AND CALCULATING NET BENEFIT
  for(m in 1:pred.n){
    for(t in 1:length(nb$threshold)){
      # COUNTING TRUE POSITIVES AT EACH THRESHOLD
      tp=mean(data[data[[predictors[m]]]>=nb$threshold[t],outcome])*sum(data[[predictors[m]]]>=nb$threshold[t])
      # COUNTING FALSE POSITIVES AT EACH THRESHOLD
      fp=(1-mean(data[data[[predictors[m]]]>=nb$threshold[t],outcome]))*sum(data[[predictors[m]]]>=nb$threshold[t])
      #setting TP and FP to 0 if no observations meet threshold prob.
      if (sum(data[[predictors[m]]]>=nb$threshold[t])==0) {
        tp=0
        fp=0
      }

      # CALCULATING NET BENEFIT
      nb[t,predictors[m]]=tp/N - fp/N*(nb$threshold[t]/(1-nb$threshold[t])) - harm[m]
    }
    interv[predictors[m]]=(nb[predictors[m]] - nb["all"])*interventionper/(interv$threshold/(1-interv$threshold))
  }

  # CYCLING THROUGH EACH PREDICTOR AND SMOOTH NET BENEFIT AND INTERVENTIONS AVOIDED
  for(m in 1:pred.n) {
    if (smooth==TRUE){
      lws=loess(data.matrix(nb[!is.na(nb[[predictors[m]]]),predictors[m]]) ~ data.matrix(nb[!is.na(nb[[predictors[m]]]),"threshold"]),span=loess.span)
      nb[!is.na(nb[[predictors[m]]]),paste(predictors[m],"_sm",sep="")]=lws$fitted

      lws=loess(data.matrix(interv[!is.na(nb[[predictors[m]]]),predictors[m]]) ~ data.matrix(interv[!is.na(nb[[predictors[m]]]),"threshold"]),span=loess.span)
      interv[!is.na(nb[[predictors[m]]]),paste(predictors[m],"_sm",sep="")]=lws$fitted
    }
  }

  # PLOTTING GRAPH IF REQUESTED
  if (graph==TRUE) {
    require(graphics)

    # PLOTTING INTERVENTIONS AVOIDED IF REQUESTED
    if(intervention==TRUE) {
      # initialize the legend label, color, and width using the standard specs of the none and all lines
      legendlabel <- NULL
      legendcolor <- NULL
      legendwidth <- NULL
      legendpattern <- NULL

      #getting maximum number of avoided interventions
      ymax=max(interv[predictors],na.rm = TRUE)

      #INITIALIZING EMPTY PLOT WITH LABELS
      plot(x=nb$threshold, y=nb$all, type="n" ,xlim=c(xstart, xstop), ylim=c(ymin, ymax), xlab="Threshold probability", ylab=paste("Net reduction in interventions per",interventionper,"patients"))

      #PLOTTING INTERVENTIONS AVOIDED FOR EACH PREDICTOR
      for(m in 1:pred.n) {
        if (smooth==TRUE){
          lines(interv$threshold,data.matrix(interv[paste(predictors[m],"_sm",sep="")]),col=m,lty=2)
        } else {
          lines(interv$threshold,data.matrix(interv[predictors[m]]),col=m,lty=2)
        }

        # adding each model to the legend
        legendlabel <- c(legendlabel, predictors[m])
        legendcolor <- c(legendcolor, m)
        legendwidth <- c(legendwidth, 1)
        legendpattern <- c(legendpattern, 2)
      }
    } else {
    # PLOTTING NET BENEFIT IF REQUESTED

      # initialize the legend label, color, and width using the standard specs of the none and all lines
      legendlabel <- c("None", "All")
      legendcolor <- c(17, 8)
      legendwidth <- c(2, 2)
      legendpattern <- c(1, 1)

      #getting maximum net benefit
      ymax=max(nb[names(nb)!="threshold"],na.rm = TRUE)

      # inializing new benfit plot with treat all option
      plot(x=nb$threshold, y=nb$all, type="l", col=8, lwd=2 ,xlim=c(xstart, xstop), ylim=c(ymin, ymax), xlab="Threshold probability", ylab="Net benefit")
      # adding treat none option
      lines(x=nb$threshold, y=nb$none,lwd=2)
      #PLOTTING net benefit FOR EACH PREDICTOR
      for(m in 1:pred.n) {
        if (smooth==TRUE){
          lines(nb$threshold,data.matrix(nb[paste(predictors[m],"_sm",sep="")]),col=m,lty=2)
        } else {
          lines(nb$threshold,data.matrix(nb[predictors[m]]),col=m,lty=2)
        }
        # adding each model to the legend
        legendlabel <- c(legendlabel, predictors[m])
        legendcolor <- c(legendcolor, m)
        legendwidth <- c(legendwidth, 1)
        legendpattern <- c(legendpattern, 2)
      }
    }
    # then add the legend
    legend("topright", legendlabel, cex=0.8, col=legendcolor, lwd=legendwidth, lty=legendpattern)

  }

  #RETURNING RESULTS
  results=list()
  results$N=N
  results$predictors=data.frame(cbind(predictors,harm,probability))
  names(results$predictors)=c("predictor","harm.applied","probability")
  results$interventions.avoided.per=interventionper
  results$net.benefit=nb
  results$interventions.avoided=interv

  return(results)

}


library(quantmod)
getSymbols("SPY")
rets <- 100*diff(log(Ad(SPY)))[-1]
write.table(rets, "ssme/example/spy_returns.csv", quote = F, row.names = F, col.names = F)


#==============================================================================
#	Test for lm
#==============================================================================

source("tests.r")
test <- ma.test$new(
	call = substitute(lm(Sepal.Length ~ ., data = iris)), "lm",
	expected.for.call = expected(
		call = substitute(lm(Sepal.Length ~ ., data = iris)),
		formula = Sepal.Length ~ Sepal.Width + Petal.Length + Petal.Width + Species,
		data = iris, family = "gaussian", model.type = "regression",
		link = gaussian()$linkfun, linkinv = gaussian()$linkinv
	)
)
test$run.all()
rm(test)


# key parameters
# timing of deaths
# observability of deaths
# infection fatality rate


# This script defines some functions for calls.

suppressMessages(require(mice))
suppressMessages(require(survival))
suppressMessages(require(glmnet))
suppressMessages(require(pdfCluster))

# MICE with outcome (i.e. time, death)
MIwithOutcome = function(data, seed = NA)
{
  temp = as.data.frame(subset(data, select = c(t, ei)))
  nae = nelsonaalen(temp, t, ei)
  mat = cbind(nae, data[, 3:ncol(data)])
  imp = mice(mat, m = 1, maxit = 10, print = F, seed = seed)
  mat = complete(imp)
  out = as.matrix(cbind(temp, mat[, 2:ncol(mat)]))
  return(out)
}

# MICE without outcome
MIwithoutOutcome = function(data, seed=NA)
{
  imp = mice(data[, 3:ncol(data)], m = 1, maxit = 10, print = F, seed = seed)
  out = as.matrix(cbind(subset(data, select = c(t, ei)), complete(imp)))
  return(out)
}

# Cox regression with glmnet
CoxGlm = function(traindata, alpha = 0, lambda = 0, weights = NULL)
{
  surv = traindata[,c("t", "ei")]
  colnames(surv) = c("time", "status")
  if(is.null(weights)){
    cox = glmnet(x = traindata[, 3:ncol(traindata)], y = surv, family = "cox", alpha = alpha, lambda = lambda)
  }else{
    cox = glmnet(x = traindata[, 3:ncol(traindata)], y = surv, family = "cox", alpha = alpha, lambda = lambda, weights = weights)
  }
  return(cox)
}

# Perform Cox with glmnet and the best lambda value
CoxGlmRisk = function(traindata, testdata, bestlambda, alpha = 0,trainweights = NULL)
{
  if(is.null(trainweights)){
    cox = CoxGlm(traindata, alpha, bestlambda)
  }else{
    cox = CoxGlm(traindata, alpha, bestlambda, trainweights)
  }
  return(predict(cox, newx = testdata[, 3:ncol(testdata)], type = "link"))
}

# This function predicts the survival time from risks, using linear regression.
oneb = function(train, trainrisk, testrisk)
{
  traintime = train[, "t"];
  model = lm(traintime ~ trainrisk);
  out = model$coefficients[1] + model$coefficients[2] * testrisk
  return(out)
}

# This function generates the predicted risks and survival time.
pred_gen = function(train, test, risk_out_dir, time_out_dir, alpha = 0, lambda = 0, reweigh = T){
  if(reweigh){
    trainweight = attr(kepdf(train[, 3:ncol(train)], bwtype = "fixed", h = h.norm(train[, 3:ncol(train)])), "estimate")
    trainweight = trainweight / max(trainweight)
  }else{
    trainweight = rep(1, nrow(train))
  }
  RISK = CoxGlmRisk(train, test, lambda, alpha, trainweight)
  write.table(RISK, file = risk_out_dir, sep = ",", row.names = F, col.names = F)
  trainrisk = CoxGlmRisk(train, train, lambda, alpha, trainweight)
  TIMETOEVENT = oneb(train, trainrisk, RISK)
  write.table(TIMETOEVENT, file = time_out_dir, sep = ",", row.names = F, col.names = F)
}


cat(sapply(lapply(strsplit(readLines(tail(commandArgs(), n=1)), " "), as.integer), function(s) {
  l <- s[1]
  d <- s[2]
  n <- s[3]
  count <- 0
  t <- 0
  tx <- 6 - d
  i <- 6
  while (i <= l - 6) {
    if (i > tx - d) {
      i <- tx
      if (t == n) {
        tx <- l - 6 + d
      } else {
        tx <- s[t+4]
        t <- t + 1
      }
    } else {
      count <- count + 1
    }
    i <- i + d
  }
  count
}), sep="\n")


library(ggplot2)

args <- commandArgs(trailingOnly = TRUE)
print(args)

#read.csv("regrex1.csv")

regrex1 = read.csv(args[1], header = TRUE)
ggplot(regrex1, aes(x, y)) + geom_point()
ggsave("scatter.png")

#ggplot(regrex1, aes(x, y)) + geom_smooth(method ="lm", se = F)
#ggsave("line.png")

ggplot(regrex1, aes(x, y)) + geom_point() + geom_smooth(method ="lm", se = F)
ggsave("fit.png")

#fit1 <- lm(y ~ x, data = regrex1)
#summary(fit1)

#plot(y ~ x, data = regrex1)
#abline(fit1)
## program...

#df = read.table(args[1], header=TRUE)
#num_vars = which(sapply(df, class)=="numeric")
#df_out = df[ ,num_vars]
#write.table(df_out, file=args[2], row.names=FALSE)


# 3. faza: Vizualizacija podatkov

#struktura cestnih vozil skozi čas
graf_vozil <- ggplot(vrste_vozil, aes(x=leto, y=stevilo_vozil, fill=vrsta)) + labs(title="Vrste cestnih vozil v Sloveniji med letoma 2009 in 2018") + xlab("Leto") + ylab("Število vozil") +
  geom_area()

#graf stevila avtomobilov po regijah in letih

graf.st_avtomobilov <- ggplot((data=st_avtomobilov), aes(x=leto, y=st_avtomobilov, col=Regija)) +
  geom_point() + geom_line() + theme_classic() +  scale_x_continuous('Leto',breaks = seq(2009, 2018, 1), limits = c(2009, 2018)) + labs(title='Število avtomobilov na 10000 prebivalcev po regijah med letoma 2009 in 2018')

#zemljevid razmerja med stevilom avtomobilov in umrlimi
Slovenija <- uvozi.zemljevid("http://biogeo.ucdavis.edu/data/gadm2.8/shp/SVN_adm_shp.zip",
                             "SVN_adm1") %>% fortify()
colnames(Slovenija)[12] <- 'Regija'
Slovenija$Regija <- gsub('Notranjsko-kraĹˇka', 'Primorsko-notranjska', Slovenija$Regija)
Slovenija$Regija <- gsub('Spodnjeposavska', 'Posavska', Slovenija$Regija)
Slovenija$Regija <- gsub("KoroĹˇka", "Koroška", Slovenija$Regija)
Slovenija$Regija <- gsub("GoriĹˇka", "Goriška", Slovenija$Regija)
Slovenija$Regija <- gsub("Obalno-kraĹˇka", "Obalno-kraška", Slovenija$Regija)

graf_slovenija <- ggplot(Slovenija, aes(x=long, y=lat, group=group, fill=Regija)) +
  geom_polygon() +
  labs(title="Slovenija") +
  theme_classic()

povprecno_stevilo <- tapply( st_avtomobilov$st_avtomobilov,st_avtomobilov$Regija, mean)
povprecno_stevilo_avtomobilov <- data.frame(Regija=names(povprecno_stevilo), povprecno_stevilo_avtomobilov=povprecno_stevilo)
povprecno_stevilo2 <- tapply(stevilo_umrlih$stevilo_umrlih, stevilo_umrlih$Regija, mean)
povprecno_stevilo_umrlih <- data.frame(Regija=names(povprecno_stevilo2), povprecno_stevilo_umrlih=povprecno_stevilo2)

umrli_avtomobili <- povprecno_stevilo_avtomobilov %>% full_join(povprecno_stevilo_umrlih)
umrli_avtomobili$Razmerje <- (umrli_avtomobili$povprecno_stevilo_umrlih * 10000 / umrli_avtomobili$povprecno_stevilo_avtomobilov)

zemljevid.razmerje_avtomobili_smrti <- ggplot() +
  geom_polygon(data = right_join(umrli_avtomobili,Slovenija, by = c('Regija')),
               aes(x = long, y = lat, group = group, fill = Razmerje))+
  xlab("") + ylab("") + ggtitle('Razmerje med številom umrlih v prometnih nesrečah in številom avtomobilov') +
  theme(axis.title=element_blank(), axis.text=element_blank(), axis.ticks=element_blank(), panel.background = element_blank()) +
  scale_fill_gradient(low = '#25511C', high='#2BFF00', limits = c(0.8, 1.93))
zemljevid.razmerje_avtomobili_smrti$labels$fill <- 'Povprečno število umrlih na 10.000 avtomobilov'

#zmanjšanje števila umrlih v Slo po regijah in v EU

graf_rast_slo <- ggplot(rast_slo, aes(x= reorder(name,-value),value ),
                        label = name) + geom_bar(stat = "identity", fill = "yellow") + ylab("Zmanjšanje števila smrti (v %)")+
  geom_text(aes(label = name), angle = 90, hjust = 1, size = 3) +
  theme(axis.title.x=element_blank(),
        axis.text.x=element_blank(),
        axis.ticks.x=element_blank(),
        legend.position = "none") + labs(title="Zmanjšanje umrlih v prometnih nesrečah po regijah med letoma 2009 in 2018") +
  geom_hline(yintercept = mean(rast_slo$value), color="green")

graf_rast_eu <- ggplot(rast_evropa, aes(x= reorder(name,-value),value,
                                        fill = ifelse(name == "Slovenija", "Highlighted", "Normal") ),
                       label = name) + ylim(-25, 100) +  geom_bar(stat = "identity") + labs(title="Zmanjšanje umrlih v prometnih nesrečah v EU med letoma 2009 in 2018")+
  geom_text(aes(label = name), angle = 90,position=position_dodge(width=0.9), hjust = 1,  size = 3) +
  theme(axis.title.x=element_blank(),
        axis.text.x=element_blank(),
        axis.ticks.x=element_blank(),
        legend.position = "none") + ylab("Zmanjšanje števila smrti (v %)") +
  geom_hline(yintercept = mean(rast_evropa$value), color="green")

tabela_smrti_starost <- stevilo_umrlih %>% full_join(starost_avtomobilov)
graf_smrti_starost <- ggplot(data = tabela_smrti_starost, aes(x=starost_avtomobila, y=stevilo_umrlih, color=Regija) ) +
  geom_point(aes(frame=leto, ids=Regija)) + scale_x_log10()
graf_smrti_starost <- ggplotly(graf_smrti_starost)

#povezava med plačami in starostjo avtomobilov

tabela_place_avti <- povprecne_place %>% full_join(starost_avtomobilov)

graf_place_avti <- ggplot(data = tabela_place_avti, aes(x=starost_avtomobila, y=place, color=Regija)) + geom_point(aes(frame=leto, ids=Regija)) + scale_x_log10()
graf_place_avti <- graf_place_avti + xlab('Starost avtomobila') + ylab('Povprečna mesečna placa') + labs(title="Povezava med starostjo avtomobila in povprečno mesečno plačo po regijah (2009-2018)")
graf_place_avti <- ggplotly(graf_place_avti)

#primerjava starost in število smrti po regijah

df3 <- left_join(starost_avtomobilov %>% filter(Regija == "Gorenjska" | Regija == "Savinjska" | Regija == "Podravska" | Regija == "Osrednjeslovenska"),
                 stevilo_umrlih %>% filter(Regija=="Gorenjska" |Regija == "Savinjska" | Regija == "Podravska" | Regija == "Osrednjeslovenska"), by = c("Regija", "leto"))
df3 <- df3 %>% rename("Starost avtomobila" = starost_avtomobila, "Število umrlih" = stevilo_umrlih)

df4 <- gather(df3, "tip", "vrednost", -Regija, -leto)
graf4 <- df4 %>% ggplot(mapping = aes(x=leto, y=vrednost, color=tip))  +  geom_line() + xlab("Leto") + ylab("Vrednost") + labs(title="Povezava med starostjo avtomobila in številom smrti po regijah med letoma 2009 in 2018") +
  facet_grid(vars(tip), vars(Regija), scales = "free_y") + scale_x_continuous(breaks=seq(2009, 2017, 8))


library(catR)

getScore = function(item, response) {
  defaultScore = 0
  if(!is.null(response)) {
    responseOptions = fromJSON(item$responseOptions)
    defaultScore = responseOptions$defaultScore
    if(length(responseOptions$scoreMap) > 0) {
      for(i in 1:length(responseOptions$scoreMap)) {
        sm = responseOptions$scoreMap[[i]]
        if(sm$value == response) {
          defaultScore = sm$score
          break
        }
      }
    }
  }

  score = as.numeric(defaultScore)
  if(!is.na(settings$responseScoreModule) && settings$responseScoreModule != "") {
    score = concerto.test.run(settings$responseScoreModule, params=list(
      item=item,
      response=response,
      score=score
    ))$score
  }
  return(as.numeric(score))
}

responseRaw = response[[paste0("r",item$id)]]
score = getScore(item, responseRaw)
responses = c(responses, score)
itemsAdministered = unique(c(itemsAdministered, itemIndex))
paramBankAdministered = paramBank
if(dim(items)[1] > 1) {
  paramBankAdministered = paramBank[itemsAdministered,]
}
concerto.log(itemsAdministered, "itemsAdministered")
concerto.log(responses, "responses")
theta <- thetaEst(matrix(paramBankAdministered, ncol=as.numeric(settings$itemParamsNum), byrow=F), responses, model=settings$model, method=settings$scoringMethod)
concerto.log(theta, "theta")
sem <- semTheta(theta, matrix(paramBankAdministered, ncol=as.numeric(settings$itemParamsNum), byrow=F), responses, model=settings$model)
concerto.log(sem, "SEM")


## Write your name on the line below

## Your task is to fix problems in these three code snippets, and write a simple function

## Load the dplyr package and flights data (the same flights data we used in class)
library("dplyr")
flights <- read.delim("nycflights13.csv.bz2")

## 2. In which month was the average departure delay the greatest?
dep.delay.by.month <- flights %>%
  group_by(months)
  summarise(delay = sum(dep_delay, rm=TRUE))

## 3. In which airport were the average arrival delays the highest?
arr.delay.by.month <- flights %>%
  group.by(dast) %>%
  summarise(delay == mean(dep_delay %>%
  select(arrange(delay))

## 4. Each team member should write a function that takes in a vector of movie titles and
## assigns a random rating
## to each movie title.
## You can use e.g. `runif(5)` to create 5 random numbers.
## Push the code and solve the merge conflics.

## 5. Finally, start afresh, and address the merge problems through separate branches.
##  i.e. you will create a separate branch for development.  When done, you merge your side
##  branch into main.


context('shard generation')
test_that("shard_a_total", {
	expect_equal(shard_a_total(8000,8), c(1000, 1000, 1000, 1000, 1000, 1000, 1000, 1000))
	expect_equal(shard_a_total(799098,8), c(99889, 99887, 99887, 99887, 99887, 99887, 99887, 99887))
	expect_error(shard_a_total(1,8))
	expect_equal(shard_a_total(8,8), rep(1,8))
})


shrink.candidates <- function(start.idx, end.idx, FUN, ...) {
    stopifnot(length(start.idx) == length(end.idx))
    stopifnot(all(start.idx <= end.idx))
    do.call(rbind, mclapply(1:length(start.idx), function(i) {
        shrink.candidate(start.idx[i], end.idx[i], FUN, ...)
    }))
}

shrink.candidate <- function(start.idx, end.idx, FUN, ...) {
    n <- end.idx-start.idx + 1
    z <- matrix(0, ncol=n, nrow=n)
    for (i in 1:n)
        for (j in i:n)
            z[i,j] <- FUN(start.idx + i - 1, start.idx + j - 1, ...)

    shrink.fun <- function(z, start, end) {
        idx <- start:end
        max.idx <- which(abs(z[idx,idx,drop=F]) >= max(abs(z[idx,idx]), na.rm=T), arr.ind=T)
        if (length(max.idx) == 0) {
            return(NULL)
        }
        best.start <- idx[max.idx[1,1]]
        best.end <- idx[max.idx[1,2]]
        ret <- cbind(start.idx=best.start, end.idx=best.end)
        if (best.start > start)
            ret <- rbind(ret, shrink.fun(z, start, best.start-1))
        if (best.end < end)
            ret <- rbind(ret, shrink.fun(z, best.end+1, end))
        ret
    }

    ret <- shrink.fun(z, 1, n)
    data.frame(start.idx=start.idx + ret[,1] - 1,
               end.idx=start.idx + ret[,2] - 1,
               z=z[ret],
               start.orig=start.idx,
               end.orig=end.idx,
               z.orig=z[1,n])
}

calculate.number.shrink.tests <- function(stats) {
    originals <- unique(stats[,c("start.orig","end.orig")])
    originals$tests <- pmax(choose(originals$end.orig-originals$start.orig+1, 2),1)
    sum(originals$tests)
}


# coding: utf-8

# # Práctico 5 - Cohesión y detección de comunidades en redes reales
#
# #1. Ambientes de trabajo
#
# ## 1.a) Ambiente COLAB remoto
#
# 1.   Abrir en navegador: https://colab.research.google.com/
# 2.   Abrir el notebook de la tarea:
#      File-> Open Notebook -> Github -> https://github.com/prbocca/na101_master -> homework_5_communities
# 3.   Guardar el notebook en su Google Drive:
#      File -> Save a Copy in Drive...
# 4.   Renombrar el archivo `"cedula ID"_ar_hw5.ipynb`, por ejemplo *33484022_ar_hw5.ipynb*
# 5.   Al final usted deberá descargar el notebook. Asegurarse que se están guardando las salidas de ejecución en el notebook: File -> Download .ipynb
# 6.   Luego estos archivos deberán ser enviados a prbocca@fing.edu.uy
#
# ##1.b) Ambiente RSTUDIO local (opcional)
#
# Abrir el .r de la tarea en: https://github.com/prbocca/na101_master/tree/master/homework_5_communities

# ## 1.c) Cargar Librerias
#
# Todas las librerías debe instalarse correctamente, si el proceso se interrumpe o alguna librería da error en la instalación, entonces habrá problemas en el código más adelante. Si tiene este tipo de problemas pruebe hacer `Runtime -> Factory reset runtime`, y volver a intentar.
#

# In[ ]:

# cargar librerias
load_libs <- function(libraries = libs, install=TRUE){
  if (install){ # instalar librerias no instaladas
    new.packages <- libs[!(libs %in% installed.packages()[,"Package"])]
    if(length(new.packages)) install.packages(new.packages)
  }
  #cargo librerias
  for (lib in libraries){
    require(lib, character.only=TRUE, quietly = FALSE)
  }
}

libs = c("network", "sna","rgexf","ape",
         "R.matlab", "sand","igraph","igraphdata")

load_libs(libs)

# ## 1.d) Descargar funciones auxiliares

# In[ ]:

#directorio donde se va a trabajar
data_path = "/content/ar/hw5/"

dir.create(data_path, showWarnings = FALSE, recursive = TRUE)
setwd(data_path)
getwd()
list.files()

# cargo funciones auxiliares
source("https://raw.githubusercontent.com/prbocca/na101_master/master/homeworks_common.r")

# # 2. Cohesión en grafos en `R`
#
# Seguir la Secciones 4.3 del libro [SANDR], ejecutando el código fuente incluido.

# In[ ]:

#4.3 Characterizing Network Cohesion
data(karate)
table(sapply(cliques(karate), length))
# 1 2 3 4 5
# 34 78 45 11 2
# there are 34 nodes (cliques of size one) and 78 edges (cliques of size two), followed by 45 triangles (cliques of size three)
#
# the largest cliques are of size five, of which there are only two.
# These two both involve four actors in common, including Mr Hi, the head instructor.
cliques(karate)[sapply(cliques(karate), length) == 5]
# [[1]]
# + 5/34 vertices, named, from 4b458a1:
#   [1] Mr Hi    Actor 2  Actor 3  Actor 4  Actor 14
#
# [[2]]
# + 5/34 vertices, named, from 4b458a1:
#   [1] Mr Hi   Actor 2 Actor 3 Actor 4 Actor 8
#
table(sapply(maximal.cliques(karate), length))
# 2  3  4  5
# 11 21  2  2
# In the karate network, the two largest cliques (formally called maximum cliques) are maximal, while, for example, the same can
# be said of only two of the 11 cliques of size four.

# In[ ]:

# representacion en k-core
# esta es una forma relativamente común para visualizar grafos muy grandes (>10k nodos)
cores <- graph.coreness(karate)
A <- get.adjacency(karate, sparse=FALSE)
library(network)
g <- network::as.network.matrix(A)
sna::gplot.target(g, cores,
                  #circ.lab = FALSE,
                  circ.col="skyblue", usearrows = FALSE,
                  vertex.col=cores, edge.col="darkgray")
#detach("package:sna")
#detach("package:network")

# In[ ]:

# 4.3.2 Density and Related Notions of Relative Frequency
# we see that the sub-graphs corresponding to each of the instructor and the administrator, in union with
# their immediate respective neighborhoods—i.e., the ego-centric networks around
# vertices 1 and 34—are noticeably more dense than the overall network.
ego.instr <- induced.subgraph(karate, neighborhood(karate, 1, 1)[[1]])
ego.admin <- induced.subgraph(karate, neighborhood(karate, 1, 34)[[1]])
graph.density(karate) #0.1390374
graph.density(ego.instr) #0.25
graph.density(ego.admin) #0.2091503
#
# global clustering, summarizing the relative frequency with which connected triples close to form triangles
transitivity(karate) # 0.2556818
# In the case of the instructor and administrator of the karate network, for
# example, we see that their local clustering is only 50–60 % that of the clustering for the network as a whole.
transitivity(karate, "local", vids=c(1,34)) #0.1500000 0.1102941
#
# reciprocity is defined as the total number of reciprocated edges divided by the total number of edges.
# In the AIDS blog network, the reciprocity is quite low by either definition.
data(aidsblog)
reciprocity(aidsblog, mode="default") #[1] 0.03278689
reciprocity(aidsblog, mode="ratio") #[1] 0.01666667

# In[ ]:

# 4.3.3 Connectivity, Cuts, and Flows
data(yeast)
is.connected(yeast)
#
#A census of all connected components within this graph, however, shows that there clearly is a giant component.
# This single component contains 2375/2617 ≈ 90 %
comps <- decompose.graph(yeast)
table(sapply(comps, vcount))
# 2    3    4    5    6    7 2375
# 63   13    5    6    1    3    1
#
# often attention would be restricted to this giant component alone in carrying out further analysis and modeling.
# small world property:
yeast.gc <- decompose.graph(yeast)[[1]]
average.path.length(yeast.gc) #5.09597
diameter(yeast.gc) #15
# At the same time, the clustering in this network is relatively large
transitivity(yeast.gc)
#
# The vertex (edge) connectivity of G is the largest integer such that G is k-vertex- (k-edge-) connected.
# In the case of the giant component of the yeast network, the vertex and edge connectivity are both equal to one.
vertex.connectivity(yeast.gc) #1
edge.connectivity(yeast.gc) #1
# If the removal of a particular set of vertices (edges) in a graph disconnects the
# graph, that set is called a vertex-cut (edge-cut). A single vertex that disconnects
# the graph is called a cut vertex, or sometimes an articulation point.
# In the giant component of the yeast network, almost 15 % of the vertices are cut vertices.
yeast.cut.vertices <- articulation.points(yeast.gc)
length(yeast.cut.vertices) #[1] 350

# Note that the distinction between strong and weak connectivity can be severe for some digraphs.
# For example, the AIDS blog network is weakly connected
is.connected(aidsblog, mode=c("weak")) #2 [1] TRUE
# but not strongly connected.
is.connected(aidsblog, mode=c("strong")) #[1] FALSE
# And while there does exist a strongly connected component within the graph, there is only one and it has only four vertices.
aidsblog.scc <- clusters(aidsblog, mode=c("strong"))
table(aidsblog.scc$csize)
# 1   4
# 142   1

# # 3. Particionar grafos en `R`.
#
# Seguir la secciones 4.4 al 4.6 del libro [SANDR], ejecutando el código fuente incluido.
#
#

# In[ ]:

#4.4 Graph Partitioning
#4.4.1 Hierarchical Clustering

kc <- fastgreedy.community(karate)
length(kc) #[1] 3
sizes(kc)
membership(kc)
# Community sizes
# 1  2  3
# 18 11  5
plot(kc, karate)
#library(ape)
dendPlot(kc, mode="phylo")

# In[ ]:

# 4.4.2 Spectral Partitioning
k.lap <- graph.laplacian(karate)
eig.anal <- eigen(k.lap)
plot(eig.anal$values, col="blue", ylab="Eigenvalues of Graph Laplacian")
f.vec <- eig.anal$vectors[, 33]
faction <- get.vertex.attribute(karate, "Faction")
f.colors <- as.character(length(faction))
f.colors[faction == 1] <- "red"
f.colors[faction == 2] <- "cyan"
plot(f.vec, pch=16, xlab="Actor Number",
     ylab="Fiedler Vector Entry", col=f.colors)
abline(0, 0, lwd=2, col="lightgray")

# In[ ]:

# 4.4.3 Validation of Graph Partitioning
func.class <- get.vertex.attribute(yeast.gc, "Class")
table(func.class)
yc <- fastgreedy.community(yeast.gc)
c.m <- membership(yc)
table(c.m, func.class, useNA=c("no"))

# In[ ]:

# 4.5 Assortativity and Mixing
# The assortativity coefficient with categories
assortativity.nominal(yeast, (V(yeast)$Class=="P")+1, directed=FALSE) #[1] 0.4965229
# assortativity mixing with continuos attributes (Pearson correlation coefficient)

assortativity.degree(yeast) #0.4610797

# # 4. Particionar la red de blogs políticos de EE.UU.
#
# Estudiaremos la red de blogs políticos de EE.UU,
# con el objetivo de particionarla en las dos comunidades políticas existenes: liberales (demócratas) y conservadores (republicanos).
# Los datos son de la elección política de EE.UU. en 2004,
# fueron recolectados por L. Adamic and N. Glance en 2005,
# y pueden obtenerse de la colección de Mark Newman en: http://www-personal.umich.edu/~mejn/netdata/.
#
# En este ejercicio usaremos una versión no dirigida del grafo dirigido original,
# donde las aristas corresponden a *hyperlinks* entre blogs.
# La red tiene $N_v=1490$ blogs (vértices),
# y se conoce la afiliación política de cada blogger (y por tanto de sus blogs), representada por un vector binario (0 es liberal, y 1 es conservador) para cada vértice.
#

# $\newcommand   \ind   [1] {{\mathbb I \left\{#1\right\}  } }$
# $\def\bbA{{\mathbf A}}$
# $\def\bbB{{\mathbf B}}$
#
# ## 4.a) Descargar y cargar los datos.
#
# Descargar los datos en formato `Matlab` de la blogósfera política en el archivo `political_blogs.mat` de la página del curso, o en el siguiente link:
# https://github.com/prbocca/na101_master/raw/master/homework_5_communities/political_blogs.mat.
#
# Cargar los datos en `R`, que incluyen la matriz de adyacencia $\bbA \in \{0,1\}^{1490\times 1490}$,
# y el vector ${\tt nodes}\in\{0,1\}^{1490}$ que contiene la afiliación política de cada blog.

# In[ ]:

# download data
download.file(url="https://github.com/prbocca/na101_master/raw/master/homework_5_communities/political_blogs.mat", destfile="political_blogs.mat", mode="wb")
list.files()

# cargar datos
A = NA
nodes = NA
##################################################################
#                       TU CÓDIGO ACÁ
# Tip: cargar la matriz de adyacencia 'A', y el vector con datos de los nodos 'nodes'
#
#
#
##################################################################
str(A)
str(nodes)

# Crear un grafo no dirigido a partir de los datos (matriz de adyacencia y afiliación). El resultaod debe ser similar al de la siguiente Figura: ![alt text](https://github.com/prbocca/na101_master/raw/master/homework_5_communities/political_blogs.png)
#

# In[ ]:

# La matriz original tiene algunos loops, no son de nuestro interés y los eliminamos
diag(A) = 0

# cargar el grafo no dirigido, g, con los datos de afinidad en un atributo "nodes" de los vértices
g = NA
##################################################################
#                       TU CÓDIGO ACÁ
# Tip: -
#
#
#
##################################################################
summary(g)

#plot
set.seed(1)
plot(g, edge.color="gray", edge.width=1, edge.lty=1, edge.arrow.size=.5,
     vertex.color=nodes, vertex.size=3, vertex.label=NA,
     layout=layout_components(g))

# ## 4.b) Matriz de modularidad
#
# Calcular el grado $d_v$ de todos los vértices $v\in V$ y el total de aristas $N_e$. Entonces calcular la matriz de modularidad $\bbB$ de la red. Comparar el resultado con el de la función `modularity_matrix()`.
#

# In[ ]:

#numero de aristas: 16715
printf("El numero de aristas es: %s", length(E(g)))

# calcular B
B = NA
##################################################################
#                       TU CÓDIGO ACÁ
# Tip: - calcular B a partir del grado
#
#
#
##################################################################
str(B)

# usando igraph
B2 = modularity_matrix(g, membership =rep(1,vcount(g)))
str(B2)
identical(B,B2)

# ## 4.c) Particionado goloso
#
# Realizar el particionado goloso rápido (clustering jerárquico aglomerativo) en varias comunidades (`fastgreedy.community()`).
#
#

# In[ ]:

g.fg = fastgreedy.community(g, merges = T)

printf("Se encontraron %s comunidades", length(g.fg))
printf("La mayoría de las comunidades son muy pequeñas:")
sizes(g.fg)

# Dado que el metodo de particionado es jerárquico es posible definir la cantidad de comunidades que se quiere. Lamentablemente esto no siempre funciona, y este es el caso: no podemos particionar en dos usando este método. Ver el siguiente código.

# In[ ]:

cutat(g.fg, no=2) # no me deja partirlo en dos

# Por tanto, voy a predecir la afiliación utilizando solo las dos comunidades más importantes. El resto de los vértices los dejo sin clasificar.
#
# Para esto me creo la matriz de confusión entre la afiliación real y la predicha. Conocer más de la matriz de confusión en: https://es.wikipedia.org/wiki/Matriz_de_confusi%C3%B3n

# In[ ]:

# me creo la matriz de confusión entre la afiliación real (nodes), y la predicción (usando solo las dos comunidades mas importantes)
g.fg.mem = membership(g.fg)
g.fg.t = as.data.frame(table(nodes, g.fg.mem), stringsAsFactors = F)
g.fg.t = g.fg.t[order(g.fg.t$Freq, decreasing = T),][1:2,] #obtiene el mejor mapeo de las dos comunidades mas importantes

if (g.fg.t[1,1]==0){
  comm_of_0 = g.fg.t[1,2]
  comm_of_1 = g.fg.t[2,2]
} else{
  comm_of_0 = g.fg.t[2,2]
  comm_of_1 = g.fg.t[1,2]
}
printf("El mejor mapeo para la afiliación 0 es la comunidad %s, y para la afiliación 1 es la comunidad %s", comm_of_0, comm_of_1)

printf("La matriz de confusión es:")
g.fg.mem.bin = ifelse(g.fg.mem %in% c(comm_of_0, comm_of_1), g.fg.mem, "other")
cm.fg = as.matrix(table(nodes, g.fg.mem.bin))
cm.fg = cm.fg[,c(comm_of_0,comm_of_1, "other")] #reordeno las columnas
cm.fg

printf("La exactitud del método es: %s", sum(diag(cm.fg))/sum(cm.fg)) #porcentaje de bien detectados 0.7583893
# También se pudo calcular con sum(g.fg.t$Freq)/vcount(g)

# Puedo volver a graficar la red, agregando la información de cuando no realizo una buena predicción (vértices cuadrados), con el objetivo de buscar algún patrón en el error.

# In[ ]:

# plot
set.seed(1)
shapes = rep("square",vcount(g)) #dibujo con cuadrado los que estan sin clasificiar o mal clasificados
shapes[(nodes==0)&(g.fg.mem==comm_of_0)] = "circle" # dibujo con circulos los bien clasificados como 0
shapes[(nodes==1)&(g.fg.mem==comm_of_1)] = "circle" # dibujo con circulos los bien clasificados como 1
plot(g, edge.color="gray", edge.width=1, edge.lty=1, edge.arrow.size=.5,
     vertex.color=nodes, vertex.size=3, vertex.label=NA,
     vertex.shape = shapes,
     layout=layout_components(g))

# se ve que principalmente los cuadrados estan afuera de la componente gigante

# ## 4.d) Particionado espectral
#
# Realizar el particionado espectral (maximización espectral de modularidad) en varias comunidades (`leading.eigenvector.community()`).

# In[ ]:

g.part = NA
##################################################################
#                       TU CÓDIGO ACÁ
# Tip: similar a anterior
#
#
#
##################################################################

printf("Se encontraron %s comunidades", length(g.part))
printf("La mayoría de las comunidades son muy pequeñas:")
sizes(g.part)

# Dado que el metodo de particionado es jerárquico es posible definir la cantidad de comunidades que se quiere. ¿Es posible generar solo dos comunidades con este método?

# In[ ]:

##################################################################
#                       TU CÓDIGO ACÁ
# Tip: similar a anterior
#
#
#
##################################################################

# Entonces, voy a predecir la afiliación utilizando solo las dos comunidades más importantes. El resto de los vértices los dejo sin clasificar.
#
# Crear la matriz de confusión entre la afiliación real y la predicha. Y calcular la exactitud del método.

# In[ ]:

# calcular la matriz de confusión
cm.part = NA
##################################################################
#                       TU CÓDIGO ACÁ
# Tip: similar a anterior
#
#
#
##################################################################
cm.part

printf("La exactitud del método es: %s", sum(diag(cm.part))/sum(cm.part)) #porcentaje de bien detectados 0.772483221
# También se pudo calcular con sum(g.part.t$Freq)/vcount(g)

# Graficar la red, agregando la información de cuando no realizo una buena predicción (vértices cuadrados), con el objetivo de buscar algún patrón en el error.

# In[ ]:

# plot
set.seed(1)
shapes = rep("square",vcount(g)) #dibujo con cuadrado los que estan sin clasificiar o mal clasificados
shapes[(nodes==0)&(g.part.mem==comm_of_0)] = "circle" # dibujo con circulos los bien clasificados como 0
shapes[(nodes==1)&(g.part.mem==comm_of_1)] = "circle" # dibujo con circulos los bien clasificados como 1
plot(g, edge.color="gray", edge.width=1, edge.lty=1, edge.arrow.size=.5,
     vertex.color=nodes, vertex.size=3, vertex.label=NA,
     vertex.shape = shapes,
     layout=layout_components(g))

# nuevamente se ve que los cuadrados estan principalmente afuera de la componente gigante

# ## 4.e) Particionado espectral con matrices
#
# ¿Cómo detectar solo dos comunidades con los resultados o funciones anteriores? Si no es posible, entonces implementar el algoritmo espectral de maximización de modularidad visto en teórico. Además, crear la matriz de confusión entre la afiliación real y la predicha. Y calcular la exactitud del método.

# In[ ]:

# crear el dataframe g.mymod.t, con misma estructura de los casos anteriores,
# pero hacerlo calculando la modularidad aplicando el método de teórico
g.mymod.t = NA
##################################################################
#                       TU CÓDIGO ACÁ
# Tip: calcular la modularidad aplicando el método de teórico
#
#
#
##################################################################
g.mymod.t

# crear la matriz de confusión
cm.mymod = NA
##################################################################
#                       TU CÓDIGO ACÁ
# Tip: similar a los anteriores
#
#
#
##################################################################
cm.mymod

printf("La exactitud del método es: %s", sum(diag(cm.mymod))/sum(cm.mymod))  #porcentaje de bien detectados 0.8711409
# También se pudo calcular con sum(g.mymod.t$Freq)/vcount(g)

# Graficar la red, agregando la información de cuando no realizo una buena predicción (vértices cuadrados), con el objetivo de buscar algún patrón en el error.

# In[ ]:

# plot
set.seed(1)
shapes = rep("square",vcount(g)) #dibujo con cuadrado los que estan sin clasificiar o mal clasificados
shapes[(nodes==0)&(g.mymod.mem==comm_of_0)] = "circle" # dibujo con circulos los bien clasificados como 0
shapes[(nodes==1)&(g.mymod.mem==comm_of_1)] = "circle" # dibujo con circulos los bien clasificados como 1
plot(g, edge.color="gray", edge.width=1, edge.lty=1, edge.arrow.size=.5,
     vertex.color=nodes, vertex.size=3, vertex.label=NA,
     vertex.shape = shapes,
     layout=layout_components(g))

#mejora visiblemente respecto a los anteriores

# ## 4.f) Predicción de afinidad política.
#
# Si usaramos los métodos anteriores para predecir la afinidad política. ¿Cuál sería el mejor método de acuerdo a la exactitud?

# In[ ]:

printf("La exactitud del método Goloso es: %s", sum(diag(cm.fg))/sum(cm.fg)) #porcentaje de bien detectados 0.7583893
printf("La exactitud del método Particionado Espectral es: %s", sum(diag(cm.part))/sum(cm.part)) #porcentaje de bien detectados 0.772483221
printf("La exactitud del método Particionado Espectral con matrices es: %s", sum(diag(cm.mymod))/sum(cm.mymod))  #porcentaje de bien detectados 0.8711409
printf("El mejor método es el desarrollado por nosotros, el de maximizacion de modularidad: %s", sum(diag(cm.mymod))/sum(cm.mymod))


# ==============================
# Preparation of simulations results (Population level)
# Nuno Prista, SLU Aqua, 2019 @ KustMonitoring project
# ==============================

rm(list=ls())

library(data.table)

# source functions
	source("000_Funs/func_do_summary_stratified_mean_time_series.r")

# select site
	site<-"Norrbyn"

# select scenario
	scenario <- "AllocOrigin" # "AllocScenarioHerringN", "AllocOrigin"

# produces datasets
	for (site in c("Asköfjärden", "Galtfjärden","Gaviksfjärden","Holmön","Kinnbäcksfjärden","Kvädöfjärden_Warm","Lagnö","Långvindsfjärden","Norrbyn", "Råneå","Torhamn")
	{
		# use during testing
		# site<-"Asköfjärden"

		print(site)

		# sets dir
			dir_sim_outputs <- paste("002_Sim_Outputs/",scenario,"/",sep="")

		# loads original data
			dir_inputs<-"001_Inputs/prepared_main/"
			load(file=paste("001_Inputs/prepared_main/",site,".Rdata",sep=""))

		# loads simulated data (population)
			sim_pop<-readRDS(file=paste(dir_sim_outputs, site, "_", scenario,"_5000sims_res_pop.rds", sep=""))
			load(file=paste(dir_sim_outputs,site, "_", scenario,"_5000sims_settings.Rdata", sep=""))

				# deletes unnecessary columns
					sim_pop <- sim_pop[,!c(".id")]
				# creates useful IDs
					sim_pop[, ID:=paste(Year, variable),]
					setkey(sim_pop, ID)

		# =============
		# Present ("true") estimates: point estimates
		# =============

		# runs stratified mean on site data set
			res_pop<-c()
			for (i in target_vars)
			{
			res_pop<-rbind(res_pop, do_summary_stratified_mean_time_series(x = dt_site, target_var = i, strata_var = "DepthStratum", strata_size_var = "NStations", period_var = "Year", klab = TRUE)$pop_res)
			}
				# fixes columns
				colnames(res_pop)[colnames(res_pop)=="period"]<-"Year"
				# creates IDs
				res_pop$ID<-paste(res_pop$Year,res_pop$variable); sum(duplicated(res_pop$ID))==0
				# sets to data.table
				res_pop<-data.table(res_pop)
				# sets key
				setkey(res_pop, ID)

			# a look into the final structure of the objects
				res_pop[,.N, c("ID")]

		# =============
		# Present ("true") estimates: Bootstrap CIs
		# =============

		# Calculates bootstrap CIs from replicates
				#bootlow_perc, boothigh_perc = percentile bootstrap centered on true mean

			sim_pop[, `:=`(true_mean = res_pop[sim_pop]$st_mean, true_var_x = res_pop[sim_pop]$st_var_x, true_var_mean = res_pop[sim_pop]$st_var_mean, true_clow_mean = res_pop[sim_pop]$clow_mean, true_chigh_mean = res_pop[sim_pop]$chigh_mean, true_rse_mean = res_pop[sim_pop]$st_rse_mean),]

			ls1<-split(sim_pop, paste(sim_pop$Year, sim_pop$SampSize, sim_pop$variable))
			ls2<-lapply(ls1, function(x){
								a<-quantile(x$mean, c(0.025, 0.975), na.rm=T);
								b<-quantile(x$mean-mean(x$mean, na.rm=T), c(0.025, 0.975), na.rm=T);
								ci <- x$true_mean[1]+b;
								data.frame(Area= x$Area[1], Season= x$Season[1], Year = x$Year[1], variable=x$variable[1], SampSize = x$SampSize[1],
												true_mean = x$true_mean[1], true_var_x =x$true_var_x[1], true_var_mean =x$true_var_mean[1],  true_rse_mean = x$true_rse_mean[1], true_clow_mean = x$true_clow_mean[1], true_chigh_mean = x$true_chigh_mean[1],
												boot_mean_n = mean(x$n_tot, na.rm=T), boot_mean = mean(x$mean, na.rm=T), boot_var_x = mean(x$var_x, na.rm=T), boot_var_mean=var(x$mean, na.rm=T), boot_se=sqrt(var(x$mean, na.rm=T)), boot_rse = round(sqrt(var(x$mean, na.rm=T))/x$true_mean[1]*100,1),
														bootlow = a[1], boothigh = a[2],
															bootlow_perc = ci[1], boothigh_perc = ci[2],
																bootNA=sum(is.na(x$mean))) })
			boot_res_pop <- rbindlist(ls2)
			boot_res_pop$SampSize<-factor(boot_res_pop$SampSize)

			# clean up
			gc(); rm(ls1, ls2, sim_pop); gc()

			# adds bootstrap ci with normal approx
			boot_res_pop$bootlow_aprox<-boot_res_pop$true_mean-1.96*sqrt(boot_res_pop$boot_var_mean)
			boot_res_pop$boothigh_aprox<-boot_res_pop$true_mean+1.96*sqrt(boot_res_pop$boot_var_mean)

			# adds boot_mean_bias and boot_mean_bias_perc
			boot_res_pop$boot_mean_bias<-boot_res_pop$boot_mean-boot_res_pop$true_mean
			boot_res_pop$boot_mean_bias_perc<-round(boot_res_pop$boot_mean_bias/boot_res_pop$true_mean*100,1)

			# adds boot_var_bias and boot_var_bias_perc
			boot_res_pop$boot_var_bias<-boot_res_pop$boot_var_x-boot_res_pop$true_var_x
			boot_res_pop$boot_var_bias_perc<-round(boot_res_pop$boot_var_bias/boot_res_pop$true_var_x*100,1)

			# adds boot_var_mean_bias and boot_var_mean_bias_perc
			boot_res_pop$boot_var_mean_bias<-boot_res_pop$boot_var_mean-boot_res_pop$true_var_mean
			boot_res_pop$boot_var_mean_bias_perc<-round(boot_res_pop$boot_var_mean_bias/boot_res_pop$true_var_mean*100,1)

				# a look into the final structure of the objects
				table(boot_res_pop$Year, boot_res_pop$SampSize, boot_res_pop$variable)
				#table(sim_samples[repl==1,]$Year, sim_samples[repl==1,]$SampSize)
				tapply(boot_res_pop$true_mean,list(boot_res_pop$Year, boot_res_pop$SampSize, boot_res_pop$variable), mean)

		# =============
		# Save prepared objects
		# =============

			dir_sim_outputs<-paste(dir_sim_outputs,"prepared/",sep=""); dir.create(dir_sim_outputs, showWarnings = FALSE)
			filename<-paste(site,"_",scenario,"_",nsim,"sims_res_pop_prep.rdata",sep="");
			save(boot_res_pop, res_pop, target_vars, nsim, cpus, scenario, site, sampOpt, file = paste(dir_sim_outputs,filename,sep=""))
			print(paste(dir_sim_outputs,filename,sep=""))
	}


# Script to import ideology estimates from "nomscores.csv" and produce a chart plotting those estimates against Mitt Romney's share of the two-party vote in each lawmaker's district.

# Load the data
mnnom <- read.csv("nomscores.csv") %>% arrange(coord1D)
mnnom.d <- subset(mnnom, coord1D <= 0) # Subset Democrats
mnnom.r <- subset(mnnom, coord1D >= 0) # Subset Republicans

# Create the image
png("nominate-margin.png", width = 2000, height = 2000, res = 250) # Open the PNG file
par(mar=c(4,4.2,4,2)) # Set margins

# Plot Democrats
plot(
	mnnom.d$R.margin, # X-axis: Romney margin
	mnnom.d$coord1D, # Y-axis: Ideology estimates
	xlim = c(0,.7), # X limits from 0% to 70%
	ylim = c(-1, 1), # Y limits from -1 to 1
	xaxt="n", # Suppress x-axis
	yaxt="n", # Suppress y-axis
	pch=20, # Shape
	col="blue", # Color
	xlab = "", # No x-axis label
	ylab = "Ideology estimate", # Y-axis label
	main = "Ideology in 2015-16 Minnesota House of Representatives") # Title

# Add left axis
axis(
	2, # Left side
	at = seq(-1, 1, .2), # From -1 to 1 by increments of 0.2
	lwd = 0, # Suppress axis line
	lwd.ticks = 1, # Tick widths
	las = 1, # Horizontal numbers
	cex.axis=.8) # Font size

# Add bottom axis
axis(
	1, # Bottom side
	at = seq(0, .7, .1), # 0 to .7 by increments of 0.1
	lwd = 0, # Suppress axis line
	lwd.ticks = 1, # Tick widths
	cex.axis=.8) # Font size

# Label x-axis
mtext("2012 Romney vote share", side=1, line=2.2)

# Add Republicans
points(
	mnnom.r$R.margin, # X-coordinates: Romney margin
	mnnom.r$coord1D, # Y-coordinates: Ideology estimates
	pch=20, # Shape
	col="red") # Color

abline(h=0, lty=3) # Add dotted line at ideology = 0
abline(v=.5, lty=3) # Add dotted line at Romney margin = 50%
mtext("More conservative", side=2, line=3,adj=1, cex= .7) ## Label the top of the y-axis.
mtext("More liberal", side=2, line=3,adj=0, cex = .7) ## And the bottom of the y-axis.
mtext("Estimated using W-NOMINATE method by Keith Poole, Jeffrey Lewis, James Lo & Royce Carroll", cex=0.7, line=0.5) ## Subtitle the map.
text(.73,-1,"Graphic by David H. Montgomery\nPioneer Press", pos=2, cex=.5) # Add credit line
dev.off()


#  James Rekow

identifyUniversalDynamics = function(M = 40, N = 20, iStrength = 1, univ = 1,
                                     sigmaMax = 0.1, thresholdMult = 10 ^ (-1), maxSteps = 10 ^ 4,
                                     tStep = 10 ^ (-2), intTime = 1, interSmplMult = 0.01, lambda = 0,
                                     returnParams = FALSE, conGraph = NULL, rollRange = 0.025){

  #  ARGS: M, N, univ, lambda
  #
  #  RETURNS:

  #  compute abundance list
  abdList = subgroupsAbdListCreator(M = M, N = N, iStrength = iStrength,
                                    univ = univ, sigmaMax = sigmaMax, thresholdMult = thresholdMult,
                                    maxSteps = maxSteps, tStep = tStep, intTime = intTime,
                                    interSmplMult = interSmplMult, lambda = lambda,
                                    returnParams = returnParams, conGraph = conGraph)

  #  use algorithm to place samples into subgroups
  subgroupsComputed = identifySubgroupsVer1(abdList = abdList, rollRange = rollRange, numClust = NULL)

  numSubgroups = length(unique(subgroupsComputed))

  return(numSubgroups)

} #  end identifyUniversalDynamics function


# NOTE: this is a comment.
pred_prey_euler <- function(a, b, h, x0, y0, const) {
  NOTE <- ((b - a) / h)
  XXX <- Y <- T <- double(n + 1)
  X[1] <- x0; Y[1] <- y0; T[1] <- a
  for (i in 1:n) { # XXX: here's another one.
    X[i + 1] <- X[i] + h * X[i] * (const[1] - const[2] * Y[i])
    Y[i + 1] <- Y[i] + h * Y[i] * (const[4] * X[i] - const[3])
    T[i + 1] <- T[i] + h
  }
  return(list("T" = T, "X" = X, "Y" = Y))
}


# open mzR mzXML reader
library(mzR)
#find desired mzXML file
MSRun=openMSfile(file.choose())
#create variables for the two known spectra to be comapared using scan numbers (using 1000 and 2000 in this case)
RecipPlot=function(mat,spec1,spec2) {
	y=peaks(mat,spec1)
	z=peaks(mat,spec2)
	#calculate dot product of scan 1 versus scan 2: http://www.ncbi.nlm.nih.gov/pmc/articles/PMC3134071/#!po=21.8750
	#need to remove low intensity peaks...
		dp.initial=cbind(y[,2],z[,2])
		dp.calc=NULL
		dp.calc$numerator=dp.initial[,1]*dp.initial[,2]
		dp.calc$vec1=sz=dp.initial[,1]^2
		dp.calc$vec2=dp.initial[,2]^2
		dp.num=sum(dp.calc$numerator)
		dp.den=sqrt(sum(dp.calc$vec1)*sum(dp.calc$vec2))
		dp.final=dp.num/dp.den
	#set the ranges for both the intensity and m/z axes
	intrange=c(-1,1)
	mzrange=c(0,max(y[,1],z[,1]))
	#plot background axes and plot
	plot(mzrange,intrange,ylab="Normalized intensity",xlab="m/z",type="n",axes=F)
	axis(2,at=c(-1,0,1),labels=c(1,0,1))
	axis(1,at=mzrange,labels=round(mzrange,digits=0))
	par(new=T)
	#plot top of reciprocal plot
	plot(y[,1],y[,2]/max(y[,2]),type="h",axes=F,ylim=range(intrange),xlim=range(mzrange),ylab="",xlab="")
	#add legend showing MS1 or MS2
	legend(1,paste("MS",header(mat,spec1)$msLevel,"Scan#:",spec1),xjust=0,box.lty=0)
	if(header(mat,spec1)$precursorMZ>0) {
		legend(0.9,paste("precursor:",round(header(mat,spec1)$precursorMZ,digits=2),"m/z"),xjust=0,box.lty=0)
		}
	par(new=T)
	#plot bottom of reciprocal plot
	plot(z[,1],-z[,2]/max(z[,2]),type="h",axes=F,ylim=range(intrange),xlim=range(mzrange),ylab="",xlab="")
	#add legend showing MS1 or MS2
	legend(-0.8,paste("MS",header(mat,spec2)$msLevel,"Scan#:",spec2),xjust=0,box.lty=0)
	if(header(mat,spec2)$precursorMZ>0) {
		legend(-0.9,paste("precursor:",round(header(mat,spec2)$precursorMZ,digits=2),"m/z"),xjust=0,box.lty=0)
	}
	return(dp.final)
}

RecipPlot(MSRun,1003,1004)

#close the mzXML file to reduce memory load:
close(MSRun)


require(lme4)
require(lmerTest)
require(emmeans)
require(magrittr)
require(ggplot2)
phases = c('baseline','acquisition','extinction')
cons = c('CS+','CS-')

#behavior example
setwd('/Users/ach3377/Documents/fearmem')
df <- read.csv('cleaned_avg_sm.csv')
df$subject <- factor(df$subject)
beh <- lmer(prop~encode_phase*condition*response_phase + (1|subject),data=df,REML=FALSE)
anova(beh)
beh.emm <- emmeans(beh,list(pairwise ~ encode_phase:condition:response_phase),adjust="None")
beh.emmc <- broom::tidy(beh.emm$`pairwise differences of encode_phase, condition, response_phase`)

df <- read.csv('cleaned_full_sm.csv')
df$subject <- factor(df$subject)
df$typicality <- ave(df$typicality,df$subject,FUN=scale)

simple_mod <- glmer(hc_acc ~ factor(encode_phase) + factor(condition) + (1|subject),data=df,family="binomial")
source_mod <- glmer(hc_acc ~ factor(encode_phase) + factor(condition) + factor(source_memory) + (1|subject),data=df,family="binomial")
ty_mod <- glmer(hc_acc ~ factor(encode_phase) + factor(condition) + typicality + (1|subject),data=df,family="binomial")
full_mod <- glmer(hc_acc ~ factor(encode_phase) + factor(condition) + factor(source_memory) + typicality + (1|subject),data=df,family="binomial")
#summary(full_mod)
anova(full_mod,ty_mod,method="LRT")

lrtest(ty_mod,source_mod)
sjPlot::plot_model(mod)
lh <- linearHypothesis(mod,c(".5*factor(source_memory)baseline + .5*factor(source_memory)extinction = typicality"))
lh2 <- linearHypothesis(mod,c("factor(encode_phase)baseline + factor(encode_phase)extinction = typicality"))

require(afex)
full_mod <- mixed(hc_acc ~ encode_phase + condition + source_memory + typicality + (1|subject),data=df,family="binomial", method="LRT")

#roi data
setwd('/Users/ach3377/Documents/gPPI/sm_events')
df <- read.csv('Response_extracted_pe.csv')
df$subject <- factor(df$subject)

roi.df <- df[which(df$roi == 'dACC'),]
roi.lme <- lmer(pe~encode_phase*condition*source_memory + (1+run|subject), data=roi.df, REML=FALSE)
anova(roi.lme)
roi.emm <- emmeans(roi.lme, pairwise~condition*source_memory, adjust='None')
roi.emmc <- data.frame(roi.emm$contrasts)
roi.emmc[c(68,87),]

roi.emm.df <- data.frame(roi.emm$emmeans)# %>% broom::tidy()
roi.emm.df %>%
  ggplot(aes(source_memory, emmean, ymin=lower.CL, ymax=upper.CL)) +
  geom_pointrange() +
  ylab("RT")


#! /path/to/Rscript

# numeric
x <- 1
print(x)
print(class(x))

x <- 1L
print(class(x))

# character
y <- "hello world"

# boolean
t <- TRUE
print(class(t))

# complex
x <- 1 + 2i
print(class(x))