## Jan 16 2021
## This R-script contains the functions created for robustness checks. Load them first

the_cov_loop <- function(offset, ycreation) { #},caliper_value,replacement){
  # A matrix will all possible covariates, and distinguish between essential and additional

  # We store in a string the name of the offset
  name_offset = offset$offset[1]

  #We pre-clean the data to speed up the computations by manually getting rid off observations that will be too far when using calipers
  offset_l <- offset %>% na_if(-9999)

  # We keep observations without na
  offset_l <- offset_l %>% drop_na()

  # We determine the caliprs for each variables
  caliper_value = 1
  caliper_slope<-caliper_value*sd(offset_l$Slope[offset_l$treated==1])
  caliper_elev<-caliper_value*sd(offset_l$Elevation[offset_l$treated==1])
  caliper_dist_road<-caliper_value*sd(offset_l$Dist_road[offset_l$treated==1])
  caliper_dist_edge<-caliper_value*sd(offset_l$Dist_edge[offset_l$treated==1])
  caliper_dist_def<-caliper_value*sd(offset_l$Dist_defor[offset_l$treated==1])

  # We keep control observations that are on the same support
  offset_l <- offset_l[offset_l$Slope > min(offset_l$Slope[offset_l$treated==1])-caliper_slope,]
  offset_l <- offset_l[offset_l$Slope < max(offset_l$Slope[offset_l$treated==1])+caliper_slope,]

  offset_l <- offset_l[offset_l$Elevation > min(offset_l$Elevation[offset_l$treated==1])-caliper_elev,]
  offset_l <- offset_l[offset_l$Elevation < max(offset_l$Elevation[offset_l$treated==1])+caliper_elev,]

  offset_l <- offset_l[offset_l$Dist_road > min(offset_l$Dist_road[offset_l$treated==1])-caliper_dist_road,]
  offset_l <- offset_l[offset_l$Dist_road < max(offset_l$Dist_road[offset_l$treated==1])+caliper_dist_road,]

  offset_l <- offset_l[offset_l$Dist_edge > min(offset_l$Dist_edge[offset_l$treated==1])-caliper_dist_edge,]
  offset_l <- offset_l[offset_l$Dist_edge < max(offset_l$Dist_edge[offset_l$treated==1])+caliper_dist_edge,]

  offset_l <- offset_l[offset_l$Dist_defor > min(offset_l$Dist_defor[offset_l$treated==1])-caliper_dist_def,]
  offset_l <- offset_l[offset_l$Dist_defor < max(offset_l$Dist_defor[offset_l$treated==1])+caliper_dist_def,]

  # We only keep the ppol of covaiates, treatment index and outcome
  db<-offset_l[,c(4:7,9:14)]
  treated <- offset_l$treated
  treeloss <- offset_l$Tree_loss

  # We define two set of covariates
  covariates_min <- names(db[,c(3,4,7,9,10)])  # A set of minimal covariates that should be included in any matching
  covariates_add <- names(db[,c(1,2,5,6,8)])    # A set of standard covariates that can be included as well

  # We determine how many different models can be constructed based on the inclusion of additional covariates
  id <- unlist(
    lapply(1:length(covariates_add),
           function(i)combn(1:length(covariates_add),i,simplify=FALSE)
    )
    ,recursive=FALSE)

  # We create all combinations of required + optional covariates
  mydbs_full <- lapply(id,function(i) c(covariates_min, covariates_add[i]))

  # We loop over all possible models based on any combination of

  maha <- lapply(mydbs_full, function(cov) {

    idx <- match(cov, names(db))   # We determines the columns of the covariates
    idx <- sort(idx)               # We need to arrange them in increasing order
    NewDF <- db[,c(idx)]           # We create a database that contains only the covariates needed in this iteration of the loop

    formulae  <- as.formula(paste("treated ~ ", paste0(names(NewDF),collapse ="+")))  # We create a formula to be inserted in the matching

    # Calipers
    cal=rep(caliper_value,length(cov)) # In the version 4.0 of matchIT, we now need to put calipers for each variables included in the model
    names(cal) <- cov         # We name the vestor to be inserted in the matching function

    # Applying the matching function to
    eval_code <- TRUE
    m.out <- tryCatch(
      matchit(formulae, data= cbind(treated,NewDF,treeloss),
              method= "nearest",
              distance = "mahalanobis",
              replace = F,
              caliper = cal), error = function(e) {eval_code <<- FALSE})

    if(eval_code) {
      # Summarise results #
      match_output <-summary(m.out, standardize = TRUE)

      # Extract useful summary values and combine into one dataset #
      test <- as.data.frame(match_output$sum.matched[,3])
      colnames(test) <- "Stand_Mean_Diff"
      mean_std_diff <- mean(abs(test$Stand_Mean_Diff))        # Mean value of the std diff
      max_std_diff <- max(abs(test$Stand_Mean_Diff))          # Max value of the std diff
      unmatched <- match_output$nn[5,2]

      cov_balance <- cbind(unmatched, mean_std_diff,max_std_diff)

      # Create db
      m.data <- match.data(m.out)

      # Aggregate pixels into treatment (offset_l_l) and control groups. Tabulate the number of pixels by tree loss year within each group (count of number of pixels within each group deforested each year)
      annual_defor <- m.data %>%  # As weights are created with the replace or with PSM, I change the tabulate approach of base R by a dplyr count
        count(as.factor(treated), as.factor(treeloss), wt=weights, .drop = F)

      label <- c("Sample", "Year", "Annual_Deforestation")
      names(annual_defor) <- paste0(label)

      # Have to make Year numeric for >= to work
      annual_defor$Year <- as.numeric(as.character(annual_defor$Year))

      # We delete the 0 values (aka pixels that remain forested at the end)
      annual_defor <- annual_defor[annual_defor$Year!=0,]

      # Construct data with dummy variables for time and treated to use in DiD regression
      annual_defor$Time <- ifelse(annual_defor$Year >= ycreation, 1,0)
      annual_defor$TimeF <-factor(annual_defor$Time, levels = c(0,1), labels = c("before","after"))
      annual_defor$TreatedF <- factor(annual_defor$Sample, levels = c(0,1), labels = c("control","treatment"))

      # Export the data for the FE regression later on
      save_path_name <- paste0("c:/Users/Virunga/Desktop/Data_for_FE/",
                               name_offset,
                               "/",
                               paste(substr(cov,1,1), collapse = ""), paste(substr(cov,6,6), collapse = ""),
                               ".csv")
      write.csv(annual_defor, save_path_name)

      # c) Test for parallel trends

      # Use only data from the before period #

      data_before <- annual_defor[(annual_defor$Year < ycreation),]

      Partest <- lm(log(Annual_Deforestation+1) ~ Year*TreatedF, data= data_before)
      summary(Partest)
      parralel_trend <- ifelse(summary(Partest)$coefficients[4,4]> 0.05,T,F)    # TBC If the p-val of the interaction term is larger than 0.1, then // trend #

      # d) DiD Regression

      # Formula = y ~ treatment + time + (treatment x time)

      modeldid <- lm(log(Annual_Deforestation+1) ~ TreatedF*TimeF, data= annual_defor)
      summary(modeldid)

      #---------------  We export all the information we want

      # A list of covariates that were included
      var <- as.data.frame(t(covariates_add %in% names(NewDF)))
      names(var)  <- covariates_add

      # We export
      m1i <- data.frame(coef=summary(modeldid)$coefficients[4,1],      # The coefficient of the estimation
                          se=summary(modeldid)$coefficients[4,2],        # The standard error of the coefficient
                          cov_balance,                                # The covariate balance
                          parralel_trend,                                 # Parralel trend info
                          #                      Gen=as.logical(F), NN1=as.logical(F), ebal=as.logical(F), psm=as.logical(T), lm=as.logical(F),
                          var,                                             # The extra covariates included
                          cal025=as.logical(F), cal05=as.logical(F),cal1=as.logical(T),
                          replacement=as.logical(F),
                          maha=as.logical(T), glm=as.logical(F), rf=as.logical(F),
                          #NN=ifelse(meth=="nearest",as.logical(T),as.logical(F)), genetic=ifelse(meth=="genetic", as.logical(T), as.logical(F)),
                          ratio1=as.logical(T), ratio5=as.logical(F), ratio10=as.logical(F))

    }
  }
)

  synthesis_loop_cov <<- data.frame(do.call("rbind",maha))
}

the_parameters_loop <- function(offset, ycreation, caliper_value, replacement, distance, ratio) { #},method,){

  loop_parameters <<- foreach(cali=caliper_value, .combine=rbind, .packages=c("MatchIt","dplyr")) %do% {
    foreach(rep=replacement, .combine=rbind, .packages=c("MatchIt","dplyr")) %do% {
      foreach(dist=distance, .combine=rbind, .packages=c("MatchIt","dplyr")) %do% {
#       foreach(meth=method, .combine=rbind, .packages=c("MatchIt","dplyr")) %do% {
          foreach(n=ratio, .combine=rbind, .packages=c("MatchIt","dplyr")) %do% {

          # We store in a string the name of the offset
          name_offset = offset$offset[1]

          # Replace all -9999 from AKNCONT with NA
          offset_l <- offset %>% na_if(-9999)

          # We keep observations without na
          offset_l <- offset_l %>% drop_na()

          # We determine the caliprs for each variables
          caliper_slope<-cali*sd(offset_l$Slope[offset_l$treated==1])
          caliper_elev<-cali*sd(offset_l$Elevation[offset_l$treated==1])
          caliper_dist_road<-cali*sd(offset_l$Dist_road[offset_l$treated==1])
          caliper_dist_edge<-cali*sd(offset_l$Dist_edge[offset_l$treated==1])
          caliper_dist_def<-cali*sd(offset_l$Dist_defor[offset_l$treated==1])

          # We keep control observations that are on the same support
          offset_l <- offset_l[offset_l$Slope > min(offset_l$Slope[offset_l$treated==1])-caliper_slope,]
          offset_l <- offset_l[offset_l$Slope < max(offset_l$Slope[offset_l$treated==1])+caliper_slope,]

          offset_l <- offset_l[offset_l$Elevation > min(offset_l$Elevation[offset_l$treated==1])-caliper_elev,]
          offset_l <- offset_l[offset_l$Elevation < max(offset_l$Elevation[offset_l$treated==1])+caliper_elev,]

          offset_l <- offset_l[offset_l$Dist_road > min(offset_l$Dist_road[offset_l$treated==1])-caliper_dist_road,]
          offset_l <- offset_l[offset_l$Dist_road < max(offset_l$Dist_road[offset_l$treated==1])+caliper_dist_road,]

          offset_l <- offset_l[offset_l$Dist_edge > min(offset_l$Dist_edge[offset_l$treated==1])-caliper_dist_edge,]
          offset_l <- offset_l[offset_l$Dist_edge < max(offset_l$Dist_edge[offset_l$treated==1])+caliper_dist_edge,]

          offset_l <- offset_l[offset_l$Dist_defor > min(offset_l$Dist_defor[offset_l$treated==1])-caliper_dist_def,]
          offset_l <- offset_l[offset_l$Dist_defor < max(offset_l$Dist_defor[offset_l$treated==1])+caliper_dist_def,]

          # We only keep the pool of esential covaiates, treatment index and outcome
          treated <- offset_l$treated
          treeloss <- offset_l$Tree_loss
          offset_l<-offset_l[,c(6,7,11,13,14)]

          # We create a formula to be inserted in the matching
          formulae  <- as.formula(paste("treated ~ ", paste0(names(offset_l),collapse ="+")))

          #maha <- lapply(mydbs_full, function(cov) {

          # Calipers
          cal=rep(cali,ncol(offset_l)) # In the version 4.0 of matchIT, we now need to put calipers for each variables included in the model
          names(cal) <- names(offset_l)         # We name the vestor to be inserted in the matching function

          # Applying the matching function to
          eval_code <- TRUE
          m.out <- #tryCatch(
            matchit(formulae, data= cbind(treated,offset_l,treeloss),
                    method= "nearest",
                    distance = dist,
                    replace = rep,
                    caliper = cal,
                    ratio=n)#, error = function(e) { eval_code <<- FALSE})

          if(eval_code) {
            # Summarise results #
            match_output <-summary(m.out, standardize = TRUE)

            # Extract useful summary values and combine into one dataset #
            test <- as.data.frame(match_output$sum.matched[,3])
            colnames(test) <- "Stand_Mean_Diff"
            mean_std_diff <- mean(abs(test$Stand_Mean_Diff))        # Mean value of the std diff
            max_std_diff <- max(abs(test$Stand_Mean_Diff))          # Max value of the std diff
            unmatched <- match_output$nn[5,2]

            cov_balance <- cbind(unmatched, mean_std_diff,max_std_diff)

            # Create db
            m.data <- match.data(m.out)
            m.data$weights[m.data$treated==0]<-m.data$weights[m.data$treated==0]/5

            # Aggregate pixels into treatment (offset_l) and control groups. Tabulate the number of pixels by tree loss year within each group (count of number of pixels within each group deforested each year)
            annual_defor <- m.data %>%  # As weights are created with the replace or with PSM, I change the tabulate approach of base R by a dplyr count
              count(as.factor(treated), as.factor(treeloss), wt=weights, .drop = F)

            label <- c("Sample", "Year", "Annual_Deforestation")
            names(annual_defor) <- paste0(label)

            # Have to make Year numeric for >= to work
            annual_defor$Year <- as.numeric(as.character(annual_defor$Year))

            # We delete the 0 values (aka pixels that remain forested at the end)
            annual_defor <- annual_defor[annual_defor$Year!=0,]

            # Construct data with dummy variables for time and treated to use in DiD regression

            annual_defor$Time <- ifelse(annual_defor$Year >= ycreation, 1,0)
            annual_defor$TimeF <-factor(annual_defor$Time, levels = c(0,1), labels = c("before","after"))
            annual_defor$TreatedF <- factor(annual_defor$Sample, levels = c(0,1), labels = c("control","treatment"))

            # Export the data for the FE regression later on
            save_path_name <- paste0("c:/Users/Virunga/Desktop/Data_for_FE/",
                                     name_offset,"/",
                         cali,rep,dist,n,".csv")
            write.csv(annual_defor, save_path_name)

                        # c) Test for parallel trends

            # Use only data from the before period #

            data_before <- annual_defor[(annual_defor$Year <ycreation),]

            Partest <- lm(log(Annual_Deforestation+1) ~ Year*TreatedF, data= data_before)
            summary(Partest)
            parralel_trend <- ifelse(summary(Partest)$coefficients[4,4]> 0.05,T,F)    # TBC If the p-val of the interaction term is larger than 0.1, then // trend #

            # d) DiD Regression

            # Formula = y ~ treatment + time + (treatment x time)

            modeldid <- lm(log(Annual_Deforestation+1) ~ TreatedF*TimeF, data= annual_defor)
            summary(modeldid)

            #---------------  We export all the information we want

            # A list of covariates that were included
            var <- as.data.frame(t(rep(FALSE,5)))
            names(var)  <- c("Pop_density", "Dist_sett", "Annual_Rain", "Dist_track", "Dist_river")

            # We export
            m1i <-   data.frame(coef=summary(modeldid)$coefficients[4,1],      # The coefficient of the estimation
                                se=summary(modeldid)$coefficients[4,2],        # The standard error of the coefficient
                                cov_balance,                                # The covariate balance
                               parralel_trend,                                 # Parralel trend info
                               #                      Gen=as.logical(F), NN1=as.logical(F), ebal=as.logical(F), psm=as.logical(T), lm=as.logical(F),
                               var,
                               cal025=ifelse(cali==0.25,as.logical(T),as.logical(F)), cal05=ifelse(cali==0.5,as.logical(T),as.logical(F)),cal1=ifelse(cali==1,as.logical(T),as.logical(F)),
                               replacement=ifelse(rep==T,as.logical(T),as.logical(F)),
                               maha=ifelse(dist=="mahalanobis",as.logical(T),as.logical(F)), glm=ifelse(dist=="glm",as.logical(T),as.logical(F)), rf=ifelse(dist=="randomforest",as.logical(T),as.logical(F)),
#                               NN=ifelse(meth=="nearest",as.logical(T),as.logical(F)), genetic=ifelse(meth=="genetic", as.logical(T), as.logical(F)),
                               ratio1=ifelse(n==1,as.logical(T),as.logical(F)),ratio5=ifelse(n==5,as.logical(T),as.logical(F)),ratio10=ifelse(n==10,as.logical(T),as.logical(F))
            )

          }
        }}}}}

the_cov_parameters_loop <- function(offset, ycreation, distance, replacement, caliper_value, ratio) { #},caliper_value,replacement){
  # A matrix will all possible covariates, and distinguish between essential and additional

  # We store in a string the name of the offset
  name_offset = offset$offset[1]

  # Replace all -9999 from AKNCONT with NA
  offset_l <- offset %>% na_if(-9999)

  # We keep observations without na
  offset_l <- offset_l %>% drop_na()

  # We define two set of covariates
  covariates_min <- names(offset_l[,c(6,7,11,13,14)])  # A set of minimal covariates that should be included in any matching
  covariates_add <- names(offset_l[,c(4,5,9,10,12)])    # A set of standard covariates that can be included as well

  # We determine how many different models can be constructed based on the inclusion of additional covariates
  id <- unlist(
    lapply(1:length(covariates_add),
           function(i)combn(1:length(covariates_add),i,simplify=FALSE)
    )
    ,recursive=FALSE)

  # We create all combinations of required + optional covariates

  set.seed(12345)
  mydbs_full <- lapply(id,function(i) c(sample(distance,1),
                                        sample(replacement,1),
                                        sample(ratio,1),
                                        sample(caliper_value,1),
                                        covariates_min,
                                        covariates_add[i]))

  # We loop over all possible models based on any combination of

  maha <- lapply(mydbs_full, function(cov) {

    # We determine the caliprs for each variables
    cali=as.numeric(cov[4])
    caliper_slope<-cali*sd(offset_l$Slope[offset_l$treated==1])
    caliper_elev<-cali*sd(offset_l$Elevation[offset_l$treated==1])
    caliper_dist_road<-cali*sd(offset_l$Dist_road[offset_l$treated==1])
    caliper_dist_edge<-cali*sd(offset_l$Dist_edge[offset_l$treated==1])
    caliper_dist_def<-cali*sd(offset_l$Dist_defor[offset_l$treated==1])

    # We keep control observations that are on the same support
    offset_l <- offset_l[offset_l$Slope > min(offset_l$Slope[offset_l$treated==1])-caliper_slope,]
    offset_l <- offset_l[offset_l$Slope < max(offset_l$Slope[offset_l$treated==1])+caliper_slope,]

    offset_l <- offset_l[offset_l$Elevation > min(offset_l$Elevation[offset_l$treated==1])-caliper_elev,]
    offset_l <- offset_l[offset_l$Elevation < max(offset_l$Elevation[offset_l$treated==1])+caliper_elev,]

    offset_l <- offset_l[offset_l$Dist_road > min(offset_l$Dist_road[offset_l$treated==1])-caliper_dist_road,]
    offset_l <- offset_l[offset_l$Dist_road < max(offset_l$Dist_road[offset_l$treated==1])+caliper_dist_road,]

    offset_l <- offset_l[offset_l$Dist_edge > min(offset_l$Dist_edge[offset_l$treated==1])-caliper_dist_edge,]
    offset_l <- offset_l[offset_l$Dist_edge < max(offset_l$Dist_edge[offset_l$treated==1])+caliper_dist_edge,]

    offset_l <- offset_l[offset_l$Dist_defor > min(offset_l$Dist_defor[offset_l$treated==1])-caliper_dist_def,]
    offset_l <- offset_l[offset_l$Dist_defor < max(offset_l$Dist_defor[offset_l$treated==1])+caliper_dist_def,]

    # We only keep the ppol of covaiates, treatment index and outcome
    db<-offset_l[,c(4:7,9:14)]
    treated <- offset_l$treated
    treeloss <- offset_l$Tree_loss

    idx <- match(cov, names(db))   # We determines the columns of the covariates
    idx <- sort(idx)               # We need to arrange them in increasing order
    NewDF <- db[,c(idx)]           # We create a database that contains only the covariates needed in this iteration of the loop

    formulae  <- as.formula(paste("treated ~ ", paste0(names(NewDF),collapse ="+")))  # We create a formula to be inserted in the matching

    # Calipers
    cal=rep(cali,length(cov)-4) # In the version 4.0 of matchIT, we now need to put calipers for each variables included in the model
    names(cal) <- cov[-c(1:4)]         # We name the vestor to be inserted in the matching function

    # Applying the matching function to
    eval_code <- TRUE
    m.out <- tryCatch(
      matchit(formulae, data= cbind(treated,NewDF,treeloss),
              method= "nearest",
              distance = as.character(cov[1]),
              replace = as.logical(cov[2]),
              ratio=as.numeric(cov[3]),
              caliper = cal), error = function(e) { eval_code <<- FALSE})

    if(eval_code) {
      # Summarise results #
      match_output <-summary(m.out, standardize = TRUE)

      # Extract useful summary values and combine into one dataset #
      test <- as.data.frame(match_output$sum.matched[,3])
      colnames(test) <- "Stand_Mean_Diff"
      mean_std_diff <- mean(abs(test$Stand_Mean_Diff))        # Mean value of the std diff
      max_std_diff <- max(abs(test$Stand_Mean_Diff))          # Max value of the std diff
      unmatched <- match_output$nn[5,2]

      cov_balance <- cbind(unmatched, mean_std_diff,max_std_diff)

      # Create db
      m.data <- match.data(m.out)
      m.data$weights[m.data$treated==0]<-m.data$weights[m.data$treated==0]/5

      # Aggregate pixels into treatment (offset_l_l) and control groups. Tabulate the number of pixels by tree loss year within each group (count of number of pixels within each group deforested each year)
      annual_defor <- m.data %>%  # As weights are created with the replace or with PSM, I change the tabulate approach of base R by a dplyr count
        count(as.factor(treated), as.factor(treeloss), wt=weights, .drop = F)

      label <- c("Sample", "Year", "Annual_Deforestation")
      names(annual_defor) <- paste0(label)

      # Have to make Year numeric for >= to work
      annual_defor$Year <- as.numeric(as.character(annual_defor$Year))

      # We delete the 0 values (aka pixels that remain forested at the end)
      annual_defor <- annual_defor[annual_defor$Year!=0,]

      # Construct data with dummy variables for time and treated to use in DiD regression
      annual_defor$Time <- ifelse(annual_defor$Year >= ycreation, 1,0)
      annual_defor$TimeF <-factor(annual_defor$Time, levels = c(0,1), labels = c("before","after"))
      annual_defor$TreatedF <- factor(annual_defor$Sample, levels = c(0,1), labels = c("control","treatment"))

      # Export the data for the FE regression later on
      save_path_name <- paste0("c:/Users/Virunga/Desktop/Data_for_FE/",
                               name_offset,
                               "/",
                               paste(substr(cov,1,1), collapse = ""), paste(substr(cov,6,6), collapse = ""),
                               ".csv")
      write.csv(annual_defor, save_path_name)

      if(nrow(annual_defor)>15) {

      # c) Test for parallel trends

      # Use only data from the before period #
      data_before <- annual_defor[(annual_defor$Year <ycreation),]

      Partest <- lm(log(Annual_Deforestation +1) ~ Year*TreatedF, data= data_before)
      summary(Partest)

      parralel_trend <- #tryCatch(
        ifelse(summary(Partest)$coefficients[4,4]> 0.05,T,F)#,
#        error = function(e) {Dont_skip <<- FALSE}) # TBC If the p-val of the interaction term is larger than 0.1, then // trend #

      # d) DiD Regression

      # Formula = y ~ treatment + time + (treatment x time)

      modeldid <- lm(log(Annual_Deforestation +1) ~ TreatedF*TimeF, data= annual_defor)
      summary(modeldid)

      #---------------  We export all the information we want

      # A list of covariates that were included
      var <- as.data.frame(t(covariates_add %in% names(NewDF)))
      names(var)  <- covariates_add

      # We export
      m1i <-   data.frame(coef=summary(modeldid)$coefficients[4,1],      # The coefficient of the estimation
                          se=summary(modeldid)$coefficients[4,2],        # The standard error of the coefficient
                          cov_balance,                                # The covariate balance
                          parralel_trend,                                 # Parralel trend info
                          #                      Gen=as.logical(F), NN1=as.logical(F), ebal=as.logical(F), psm=as.logical(T), lm=as.logical(F),
                          var,                                             # The extra covariates included
                          cal025=ifelse(cali==0.25,as.logical(T),as.logical(F)), cal05=ifelse(cali==0.5,as.logical(T),as.logical(F)),cal1=ifelse(cali==1,as.logical(T),as.logical(F)),
                          replacement=ifelse(as.logical(cov[2])==T,as.logical(T),as.logical(F)),
                          maha=ifelse(cov[1]=="mahalanobis",as.logical(T),as.logical(F)), glm=ifelse(cov[1]=="glm",as.logical(T),as.logical(F)), rf=ifelse(cov[1]=="randomforest",as.logical(T),as.logical(F)),
                          #                               NN=ifelse(meth=="nearest",as.logical(T),as.logical(F)), genetic=ifelse(meth=="genetic", as.logical(T), as.logical(F)),
                          ratio1=ifelse(as.numeric(cov[3])==1,as.logical(T),as.logical(F)),ratio5=ifelse(as.numeric(cov[3])==5,as.logical(T),as.logical(F)),ratio10=ifelse(as.numeric(cov[3])==10,as.logical(T),as.logical(F))
      )
      }

    }

  })

  synthesis_loop_cov_param <<- data.frame(do.call("rbind",maha))
  }

the_year_loop <- function(offset, ycreation) {

  # We store in a string the name of the offset
  name_offset = offset$offset[1]

  #We pre-clean the data to speed up the computations by manually getting rid off observations that will be too far when using calipers
  offset_l <- offset %>% na_if(-9999)

  # We keep observations without na
  offset_l <- offset_l %>% drop_na()

  # We determine the caliprs for each variables
  caliper_value = 1
  caliper_slope<-caliper_value*sd(offset_l$Slope[offset_l$treated==1])
  caliper_elev<-caliper_value*sd(offset_l$Elevation[offset_l$treated==1])
  caliper_dist_road<-caliper_value*sd(offset_l$Dist_road[offset_l$treated==1])
  caliper_dist_edge<-caliper_value*sd(offset_l$Dist_edge[offset_l$treated==1])
  caliper_dist_def<-caliper_value*sd(offset_l$Dist_defor[offset_l$treated==1])

  # We keep control observations that are on the same support
  offset_l <- offset_l[offset_l$Slope > min(offset_l$Slope[offset_l$treated==1])-caliper_slope,]
  offset_l <- offset_l[offset_l$Slope < max(offset_l$Slope[offset_l$treated==1])+caliper_slope,]

  offset_l <- offset_l[offset_l$Elevation > min(offset_l$Elevation[offset_l$treated==1])-caliper_elev,]
  offset_l <- offset_l[offset_l$Elevation < max(offset_l$Elevation[offset_l$treated==1])+caliper_elev,]

  offset_l <- offset_l[offset_l$Dist_road > min(offset_l$Dist_road[offset_l$treated==1])-caliper_dist_road,]
  offset_l <- offset_l[offset_l$Dist_road < max(offset_l$Dist_road[offset_l$treated==1])+caliper_dist_road,]

  offset_l <- offset_l[offset_l$Dist_edge > min(offset_l$Dist_edge[offset_l$treated==1])-caliper_dist_edge,]
  offset_l <- offset_l[offset_l$Dist_edge < max(offset_l$Dist_edge[offset_l$treated==1])+caliper_dist_edge,]

  offset_l <- offset_l[offset_l$Dist_defor > min(offset_l$Dist_defor[offset_l$treated==1])-caliper_dist_def,]
  offset_l <- offset_l[offset_l$Dist_defor < max(offset_l$Dist_defor[offset_l$treated==1])+caliper_dist_def,]

  # We only keep the ppol of covaiates, treatment index and outcome
  db<-offset_l[,c(4:7,9:14)]
  treated <- offset_l$treated
  treeloss <- offset_l$Tree_loss

  # We define the set of covariates
  covariates <- names(db[,c(3,4,7,9,10)])  # A set of minimal covariates that should be included in any matching

  # We keep the good covariates

    idx <- match(covariates, names(db))   # We determines the columns of the covariates
    idx <- sort(idx)               # We need to arrange them in increasing order
    NewDF <- db[,c(idx)]           # We create a database that contains only the covariates needed in this iteration of the loop

    formulae  <- as.formula(paste("treated ~ ", paste0(names(NewDF),collapse ="+")))  # We create a formula to be inserted in the matching

    # Calipers
    cal=rep(caliper_value,length(covariates)) # In the version 4.0 of matchIT, we now need to put calipers for each variables included in the model
    names(cal) <- covariates         # We name the vestor to be inserted in the matching function

    # Applying the matching function to
    m.out <-  matchit(formulae, data= cbind(treated,NewDF,treeloss),
              method= "nearest",
              distance = "mahalanobis",
              replace = F,
              caliper = cal)

      # Summarise results #
      match_output <-summary(m.out, standardize = TRUE)

      # Create db
      m.data <- match.data(m.out)

      # Aggregate pixels into treatment (offset_l_l) and control groups. Tabulate the number of pixels by tree loss year within each group (count of number of pixels within each group deforested each year)
      annual_defor <- m.data %>%  # As weights are created with the replace or with PSM, I change the tabulate approach of base R by a dplyr count
        count(as.factor(treated), as.factor(treeloss), wt=weights, .drop = F)

      label <- c("Sample", "Year", "Annual_Deforestation")
      names(annual_defor) <- paste0(label)

      # Have to make Year numeric for >= to work
      annual_defor$Year <- as.numeric(as.character(annual_defor$Year))

      # We delete the 0 values (aka pixels that remain forested at the end)
      annual_defor <- annual_defor[annual_defor$Year!=0,]

      # Construct data with dummy variables for time and treated to use in DiD regression
      annual_defor$Time <- ifelse(annual_defor$Year >= ycreation, 1,0)
      annual_defor$TimeF <-factor(annual_defor$Time, levels = c(0,1), labels = c("before","after"))
      annual_defor$TreatedF <- factor(annual_defor$Sample, levels = c(0,1), labels = c("control","treatment"))

      # d) Loop over DiD Regression

did_res <- data.frame(coef=numeric(),      # The coefficient of the estimation
                  se=numeric(),
                  Year = character())

#for (y in c(1:19)) {

annual_defor$Year <- annual_defor$Year+2000

for (y in 2001:2019) {
annual_defor2 <- annual_defor[annual_defor$Year != y,]
i = y-2000
      modeldid <- lm(log(Annual_Deforestation+1) ~ TreatedF*TimeF, data= annual_defor2)
      did_res[i,1] <- summary(modeldid)$coefficients[4,1]      # The coefficient of the estimation
      did_res[i,2] <- summary(modeldid)$coefficients[4,2]
      did_res[i,3] <- as.character(y)
  }

# We add the regression without any drop
modeldid <- lm(log(Annual_Deforestation+1) ~ TreatedF*TimeF, data= annual_defor)
summary(modeldid)
did_res[20,1] <- summary(modeldid)$coefficients[4,1]      # The coefficient of the estimation
did_res[20,2] <- summary(modeldid)$coefficients[4,2]
did_res[20,3] <- "None"

# We create a variable of whether there is a drop or not for the graphs
did_res$Drop <- ifelse(did_res$Year=="None",F,T)

did_res <<- did_res
}


# ====================
# faz_determine_best_scale
# ====================

	# deterrmines the best scale (min, max) for different variables
	# Nuno Prista, SLU Aqua, Sweden
	# 2018, Developed @ WKBIOPTIM1 and WKBIOPTIM2

	# 2018-09-10: created

		do_determine_best_scale<-function(x = ls_DT_compiled, variables = c("lenCls","age"), stats = c("cv","mwcv"), zero_is_lowest = FALSE)
			{

			out<-sapply(variables, function(x) NULL)

			for (variable1 in variables)
				{
					for (stat in stats)
					{
					y<-x[x$variable == variable1,][[stat]]
					z <- range(y, na.rm=T)
					if (zero_is_lowest) z <- c(0, max(z, na.rm=T))
					out[[variable1]][[stat]]<- z
					}
				}
			print(out)
			out
			}


## the R code ##

library(diagram)

pos <- coordinates(pos=c(3,3,3,3,3,3))

cc <- c("Start",LETTERS[2:16],"End")

openplotmat(main="Flow Chart")

for(i in seq(1,15,by = 3)) straightarrow(from = pos[i,] ,to = pos[i+3,])

for(i in c(2,5,8)) straightarrow(from = pos[i,] ,to = pos[i+6,])

segmentarrow(from = pos[16,],to=pos[2,],path="RVL",dd=0.15)

bentarrow(from = pos[8,], to=pos[6,],path='H')

bentarrow(from = pos[6,], to=pos[2,],path='V')

straightarrow(from=pos[14,],to = pos[17,])

for(i in c(2,7,13,14,16)) textrect(pos[i,],radx=0.08,rady=0.04,lab = cc[i])

for(i in c(1,17)) textround(pos[i,],radx=0.08,rady=0.04,lab = cc[i])

textdiamond(mid = pos[8,],radx = 0.15,rady = 0.08,lab = c("Has","Detect?"))

textmulti(mid = pos[4,],radx=0.1,rady=0.05,nr=6)

textmulti(mid = pos[6,],radx=0.1,rady=0.05,nr=5)

textellipse(mid = pos[10,],radx = 0.1,rady = 0.05)

text(pos[8,1]+0.2,pos[8,2]+0.03,"YES",cex = 0.8)

text(pos[11,1]+0.04,pos[11,2],"NO",cex = 0.8)


library(RMySQL)
library("neuralnet")

net.course <- readRDS("C:/xampp/htdocs/recommend3/trained_data.rds")

args <- commandArgs(TRUE)
N <- args[1]
print(N)
#N <- 'ayush.123.007@gmail.com'

mydb = dbConnect(MySQL(), user='root', password='', dbname='recommender', host='localhost')
#query <- sprintf("select english,hindi,science,socialsc,maths,ART,HIN,GEO,ELE,ACC,BAN,PTG1,POC,SPB,PYY,SPM,CHE,MTT,FTW,ISE,AOD,HIS,ZLG,WDG,TDG,GPY,BTY,EDG,ACT,ECO,MET,DAB,SUR,PHY,SOH,APY,EGL,GSC,SOA,PHS1,AMS,VTS,CEG,MEG,MAT,SOM,PHS2,HSC,GTY,MTS,ETR,MIT,RTE,CPM,q1,q2,q3,q4,q5,q6,q7,q8,q9,q10,q11,q12,oft,ofu,ugm,MI,BI,CI,HI,Neuro,Extra,PCM,PCB,COM,HUM from academic,opted,score,question,personality where academic.user='%s' and opted.user='%s' and score.user='%s' and question.user= '%s' and personality.user='%s'",N,N,N,N,N)
fetch_query <- sprintf("select english,hindi,science,socialsc,maths,percent,MI,BI,CI,HI,Neuro,Extra from academic,score where academic.user='%s' and score.user='%s'",N,N)

rs = dbSendQuery(mydb, fetch_query)
test_data = as.data.frame (fetch(rs, n=-1))

colnames(test_data) <- c("English","Hindi","Science","Social_Science","Maths","Present_Score","MI","BI","CI","HI","Neuroticism","Extraversion")

#test_data_raw <- test_data [,c("English","Hindi","Science","Social_Science","Maths","Present_Score","MI","BI","CI","HI","Neuroticism","Extraversion")]
test_data_raw <- as.numeric(test_data)
test_data_raw <- as.data.frame(t(test_data_raw))

#colnames(test_data) <- c("English","Hindi","Science","Social_Science","Maths","Present_Score","MI","BI","CI","HI","Neuroticism","Extraversion")
#test_data <-  test_data [,c("English","Hindi","Science","Social_Science","Maths","Present_Score","MI","BI","CI","HI","Neuroticism","Extraversion")]
#trainingdata[keep, drop=FALSE]

net.results <- compute(net.course, test_data_raw) #Run them through the neural network

#Lets see what properties net.sqrt has
ls(net.results)

#Lets see the results
print(net.results$net.result)

result <- as.data.frame(net.results$net.result)
colnames(result) <- c("p","b","c","h")

insert_query <- sprintf("insert into output (user,pcm,pcb,co,hu) values ('%s',%f,%f,%f,%f)",N,result[1],result[2],result[3],result[4])
rs <- dbSendQuery(mydb, insert_query)
dbClearResult(rs)


# Code by Katie Devenish. ktd19ycv@bangor.ac.uk

# This code is used in the publication entitled "Madagascar's biggest mine is set to achieve No Net Loss of Forest"
# Authors: Katie Devenish, Sebastien Desbureaux, Simon Willcock and Julia PG Jones. 2021.

# Here, we explore which of the modelling choices tested in the robustness checks most influence the regression estimates.

# Load libraries #

library("stargazer")

# --------------------- 1) Data Construction for Matching -----------------------------------------#

setwd("c:/Users/desbures/Documents/Sebastien/11_Autres/Katie/Ambatovy/Output_data/")

# We load all csv from the different loop
temp = list.files(pattern="*.csv")
myfiles = lapply(temp, read.csv)

# We include the name of the file to keep track of the offset
for (i in 1:12) {
  myfiles[[i]]$csv <- temp[i]
}

# We create one data frame
d <- do.call(rbind, myfiles)

# We create a variable for the offfset
d$offset <- substring(d$csv,5,7)
  d$offset[d$offset=="CFA"] <- "CFAM"
  d$offset[d$offset=="CZ_"] <- "CZ"
  d$offset[d$offset=="Ank"] <- "ANK"
d$offset <- as.factor(d$offset)
d$csv <- NULL

## We indentify valid models as in the main text
ANK$less_10pc_unmatched  <- ifelse(ANK$unmatched<2862*0.1,T,F)

d$less_10pc_unmatched <- ifelse(d$offset=="ANK" & d$unmatched<2862*0.1,T,
                                ifelse(d$offset=="CFAM" & d$unmatched<2626*0.1,T,
                                       ifelse(d$offset=="CZ" & d$unmatched<1340*0.1,T,
                                              ifelse(d$offset=="TTF" & d$unmatched<1170*0.1,T,F))))

# A simple reg
reg1 <- lm(coef ~ . , data=d[,-c(1,3:7,24)])
  summary(reg1)

reg2 <- lm(coef ~ . , data=d[d$less_10pc_unmatched==T,-c(1,3:7,24)])
  summary(reg2)

reg3 <- lm(coef ~ . , data=d[d$mean_std_diff<=0.25,-c(1,3:7,24)])
  summary(reg3)

reg4 <- lm(coef ~ . , data=d[d$max_std_diff<=0.25,-c(1,3:7,24)])
  summary(reg4)

reg5 <- lm(coef ~ . , data=d[d$parralel_trend==T,-c(1,3:7,24)])
  summary(reg5)

reg6 <- lm(coef ~ . , data=d[d$offset=="ANK",-c(1,3:7,23,24)])
  summary(reg6)

reg7 <- lm(coef ~ . , data=d[d$offset=="CFAM",-c(1,3:7,23,24)])
  summary(reg7)

reg8 <- lm(coef ~ . , data=d[d$offset=="CZ",-c(1,3:7,23,24)])
  summary(reg8)

reg9 <- lm(coef ~ . , data=d[d$offset=="TTF",-c(1,3:7,23,24)])
  summary(reg9)

stargazer(reg1,reg2,reg3,reg4,reg5,reg6,reg7,reg8,reg9,
          title = "Effect moddeling choices on estimated impact",
          out="mod_choices.doc",
          type = "html")


#!/usr/bin/env Rscript

# ---------- Load R environment ----------
# Setup R error handling to go to stderr
options(show.error.messages=F, error=function() { cat(geterrmessage(), file=stderr()); q("no",1,F) } )

# Set proper locale
#loc <- Sys.setlocale("LC_MESSAGES", "en_US.UTF-8")
#loc <- Sys.setlocale(category="LC_ALL", locale="C")

# Set options
#options(encoding="UTF-8")
options(stringAsfactors=FALSE, useFancyQuotes=FALSE)

# Take in trailing command line arguments
args <- commandArgs(trailingOnly=TRUE)
if (length(args) < 2) {
	print("Error! No or not enough arguments given.")
	print("Usage: $0 feat_list.tsv dendrogramm.pdf")
	quit(save="no", status=1, runLast=FALSE)
}

# Load libraries
library(mixOmics)
library(ape)
library(pvclust)
library(dendextend)
library(cba)
library(phangorn)

# Import Feature list
feat_list <- read.table(file=args[1], header=TRUE, quote="\"", sep="\t")

# Sample names
ketchup_samples <- colnames(feat_list)

# Sample classes: ketchup
ketchup <- as.factor(sapply(strsplit(as.character(ketchup_samples), "\\."), function(x) {
    nam <- x[1];
    nam;
}))

# Unique sample classes: ketchup
ketchup_names <- unique(ketchup)

# Define colors
ketchup_colors <- c("darkorange1","blue3","darkorange3","darkorange4","coral2","coral3","coral4","brown3")
ketchup_symbols <- c(0,16,1,2,5,6,7,10)

# Define samples colors
ketchup_colors <- c("darkorange1","red", "blue3","darkorange3","darkorange4","coral2","coral3","coral4","brown3")
ketchup_symbols <- c(0,15,16,1,2,5,6,7,10)

ncomp <- 5                        # Number of components
nfolds <- 5                       # Number of folds for cross-validation
nrepeat <- 10                     # Number of repeats for validation
keepx <- c(seq(10, 20, 10))       # The number of variables to test from the X data set

# Prepare data matrix
plsda_list <- as.data.frame(t(feat_list))
plsda_list[is.na(plsda_list)] <- 0

# Perform sPLS-DA
model_splsda <- splsda(X=plsda_list, Y=ketchup, multilevel=NULL, ncomp=ncomp)

# Plot full (non-selected) feature matrix
pdf("/tmp/heatmap.pdf", encoding="ISOLatin1", pointsize=12, width=10, height=6, family="Helvetica")
par(mfrow=c(1,1), mar=c(4,4,4,1), oma=c(0,0,0,0), cex.axis=0.9, cex=0.8)
model_cim <- cim(model_splsda, comp=1:ncomp, xlab="features", ylab="samples", margins=c(5, 14))
dev.off()

pdf(args[2], encoding="ISOLatin1", pointsize=12, width=5, height=6, family="Helvetica")
par(mfrow=c(1,1), mar=c(1,1,2,1), cex=1.0)
#plot(as.phylo(model_cim$ddr), type="phylogram", direction="downwards",
#     tip.color=ketchup_samples_colors, label.offset=1, use.edge.length=TRUE,
#     show.tip.label=TRUE, font=2, x.lim=c(0,17), y.lim=c(0,33), main="Dendrogramm")
plot(as.phylo(as.dendrogram(hclust(dist(t(feat_list), method="euclidean")))),
      tip.color=ketchup_samples_colors, label.offset=1, use.edge.length=TRUE,
      show.tip.label=TRUE, font=2, main="Dendrogramm")
dev.off()


# Script for phylogeny dating

# 1. Ne estimation ################################################################################################
data <- read.csv("mutation_rate.txt", sep =" ", header=FALSE)

average=mean(data[,2])
average
ne= 0.00247 /(4*mu)

# 2. Dating phylogeny ################################################################################################
library(RColorBrewer)
library(dplyr)
library(ape)
library(phytools)

gt_m = 11
# Distances
d_Pongo_abelii <- 0.0162551430672998
d_Homo_sapiens <- 0.00577676246248343
d_Pan_troglodytes <- 0.00612226407385174
d_h_c <- 0.00928793113723326
d_ape <- 0.0111854267754341
d_Macaca_mulatta <-0.00260875810745442
d_Macaca_f <- 0.0022282726931979
d_macaca_macaca <-0.00464525362885664
d_baboon <- 0.00686281100087727
d_maca_bab <- 0.00399650084545229
d_Chlorocebus_sabaeus <- 0.0111626595169656
d_m_g <- 0.0246717581129659

# Using only the new estimated on the branches in question
mu_rhesus= ((4.8399 + 1.8364 *12+ 4.6497+ 0.3042 *10)*(1-0.10887096774193548)/(2*2351302179*(1-0.04020232294960846)))
mu_m = (mu_rhesus/11)*1000000
mu_rhesus_min= ((25.158457+5.065827)*(1-0.10887096774193548)/(2*2351302179*(1-0.04020232294960846)))
CI_min= (mu_rhesus_min/11)*1000000
mu_rhesus_max= ((28.59583+10.317069)*(1-0.10887096774193548)/(2*2351302179*(1-0.04020232294960846)))
CI_max= (mu_rhesus_max/11)*1000000

# Macaca-macaca
t_m = (d_Macaca_mulatta)/(mu_m)
t_m_min = (d_Macaca_mulatta)/(CI_min)
t_m_max = (d_Macaca_mulatta)/(CI_max)
# Macaca-baboon
t_m_b = (d_Macaca_mulatta+d_macaca_macaca)/(mu_m)
t_m_b_min = (d_Macaca_mulatta+d_macaca_macaca)/(CI_min)
t_m_b_max = (d_Macaca_mulatta+d_macaca_macaca)/(CI_max)
# Macaca-green
t_m_g = (d_Macaca_mulatta+d_macaca_macaca+d_maca_bab)/(mu_m)
t_m_g_min = (d_Macaca_mulatta+d_macaca_macaca+d_maca_bab)/(CI_min)
t_m_g_max = (d_Macaca_mulatta+d_macaca_macaca+d_maca_bab)/(CI_max)

# Macaca with great apes
t_m_a = (d_Macaca_mulatta+d_macaca_macaca+d_maca_bab+d_m_g)/(mu_m)
t_m_a_min = (d_Macaca_mulatta+d_macaca_macaca+d_maca_bab+d_m_g)/(CI_min)
t_m_a_max = (d_Macaca_mulatta+d_macaca_macaca+d_maca_bab+d_m_g)/(CI_max)

##
# Babon rate:
mu_b = 0.549e-9*1000000
d_baboon/mu_b
# Green rate:
mu_g = 1.11e-9*1000000
d_Chlorocebus_sabaeus/mu_g
# Homo:
mu_h= 0.43e-9*1000000
(d_ape+d_h_c+d_Homo_sapiens)/mu_h
# Chimp
mu_c= 0.64e-9*1000000
(d_ape+d_h_c+d_Pan_troglodytes)/mu_c

# Model
mu_nwm=2.7e-9*1000000
(d_Macaca_mulatta+d_macaca_macaca)/mu_m
(d_maca_bab+d_m_g)/mu_g
d_maca_bab/mu_g
d_m_g/mu_nwm

####
tree_t_new_reg<-read.tree("tree_timed_rhesus_estimate_last_reg.nwk")
tree_t_topo<-read.tree("tree_timed_rhesus_estimate_topo_reg.nwk")
tree_t_sp<-read.tree("tree_timed_rhesus_estimate_sp_reg.nwk")

CI= rbind(c(t_m_a_min,t_m_a_max),
          c(t_m_g_min,t_m_g_max),
          c(t_m_b_min,t_m_b_max),
          c(t_m_min,t_m_max))

# speciation
minus_m=(2*79874*11)/1000000
minus_cat=(2*355000*11)/1000000

sp_t_m = t_m -minus_m
sp_t_m_a =t_m_a-minus_cat

#
png("phylo_diff_sp_n_reg_last.png", width = 1200, height = 750)
par(xaxt="n",yaxt="n",mar=c(5.1,6.1,2.1,2), mgp=c(5, 1.5, 0))
plotTree.errorbars(tree_t_new_reg, CI, fsize=3, ftype="off", lwd=10, bar.width=0, cex=2.5, xlab="",ylab="", at=seq(0,45,by=5))
#
polygon(c(sp_t_m,sp_t_m,t_m,t_m), c(1,2,2,1), col = "gray80", border="gray80")
polygon(c(sp_t_m_a,sp_t_m_a,t_m_a,t_m_a), c(3.13,5,5,3.13), col = "gray80", border="gray80")
#
axis(1, at=seq(0,55,by=5), cex.axis=2)
#
abline(v=60, lty=2, lwd=4, col="gray65")
abline(v=55, lty=2, lwd=4, col="gray65")
abline(v=50, lty=2, lwd=4, col="gray65")
abline(v=45, lty=2, lwd=4, col="gray65")
abline(v=40, lty=2, lwd=4, col="gray65")
abline(v=35, lty=2, lwd=4, col="gray65")
abline(v=30, lty=2, lwd=4, col="gray65")
abline(v=25, lty=2, lwd=4, col="gray65")
abline(v=20, lty=2, lwd=4, col="gray65")
abline(v=15, lty=2, lwd=4, col="gray65")
abline(v=10, lty=2, lwd=4, col="gray65")
abline(v=5, lty=2, lwd=4, col="gray65")
abline(v=0, lty=2, lwd=4, col="gray65")
#
lines(c(50.09,50.09),c(5,3.15), lwd=10, col="gray52")
lines(c(2.45,2.45),c(1,2), lwd=10, col="gray52")
points(c(50.09),c(4.06), lwd=15,pch=20, col="navy")
points(c(2.45),c(1.5), lwd=15,pch=20, col="navy")
par(new=TRUE)
par(xaxt="n",yaxt="n",mar=c(5.1,5.1,2.1,2), mgp=c(5, 1.5, 0))
## ftype= "reg" "i" "b"
plotTree.errorbars(tree_t_new_reg, CI, fsize=3, ftype="i", lwd=10, bar.width=20, cex=2.5, xlab="",ylab="", at=seq(0,45,by=5),bar.col="darkgreen")
##plotTree.errorbars(tree_t_sp, CI, fsize=3, ftype="i", lwd=10, bar.width=20, cex=2.5, xlab="",ylab="", at=seq(0,45,by=5),bar.col="darkblue")
##CI_s=rbind(cbind(50.09,50.09),c(18.13,18.13),c(11.69,11.69),c(2.45,2.45))
##plotTree.errorbars(tree_t_sp, CI_s, fsize=3, ftype="i", lwd=10,bar.width=20, cex=2.5, xlab="",ylab="", at=seq(0,45,by=5),bar.col="darkblue")
#
par(xaxt="s",yaxt="s",font.lab=4)
axis(1, at=seq(0,60,by=5), cex.axis=2)
#
text(c(10,19.5,30,58.2), c(1.35,2.1,2.98,3.915),labels = c("Macaca", "Papionini", "Cercopithecidae", "Catarrhini"), font=1, cex=2.3)
text(c(10,58.2), c(1.2,3.765),labels = c(expression("(N"[e]*" = 79,874)"), expression("(N"[e]*" = 355,000)")), font=2, cex=1.6)
text(c(-0.1,-2), c(1.62,1.48),labels = c(expression("T"[d]*"=4.20"),expression("T"[s]*"=2.45")), col=c("darkgreen","navy"), font=2, cex=1.8)
text(c(6.5), c(2.4),labels = c(expression("T"[d]*"=11.69")), col=c("darkgreen"), font=2, cex=1.8)
text(c(13), c(3.28),labels = c(expression("T"[d]*"=18.13")), col=c("darkgreen"), font=2, cex=1.8)
text(c(52.5,45.5), c(4.17,3.9),labels = c(expression("T"[d]*"=57.90"),expression("T"[s]*"=50.09")), col=c("darkgreen","navy"), font=2, cex=1.8)
#
# add fossils:
points(c(22,22,33.5), c(3.12,5,4.05), pch=4, lwd=5, col="red")
text(c(28,22,33.5), c(3.22,5.1,4.15),labels = c("Victoriapithecus", "Proconsul", "Aegyptopithecus"), , col=c("red"), font=3, cex=1.8)
dev.off()

# 3. compare estimate with literature ######################################################################################################################
div_me <- c(4.20,11.69,18.13,57.90)
div_lit_nucl <- c(3.53, 8.13, 11.5, 31.6)
div_lit_mito <- c(3.44, 12.17, 14.09, 32.12)

png("estimation_dif_met.png", width = 1300, height = 850)
par(mar=c(9,15,4,2), mgp=c(3, 3, 0))
plot(div_lit_mito, div_me, type='o', pch=19, lwd=4, xlim=c(0,60), ylim=c(0,60), xlab="", ylab="",
     cex=3, cex.lab=2.5, cex.axis=2.5, xaxt="n", yaxt="n", lty=1)
lines(div_lit_nucl, div_me, type='o', pch=19, lwd=4, xlab="", ylab="", cex=3, cex.lab=2.5, cex.axis=2.5, xaxt="n", yaxt="n", lty=1, col="gray60")
abline(0,1, lwd=2, lty=1, col="black")
points(div_lit_mito, div_me, pch=21, lwd=3, cex=4, cex.lab=2.5, cex.axis=2.5, col=1, bg=c("aquamarine4", "firebrick1", "dodgerblue4", "darkgoldenrod2"))
points(div_lit_nucl, div_me, pch=21, lwd=3, cex=4, cex.lab=2.5, cex.axis=2.5, col="gray60", bg=c("aquamarine4", "firebrick1", "dodgerblue4", "darkgoldenrod2"))
text(c(7.5, 18, 6.5, 38),c(1, 11.5, 26.5, 56), labels=c("Macaca", "Papionini", "Cercopithecidae","Catarrhini"),
     font=c(4,2,2,2), cex=3, col=c("aquamarine4", "firebrick1", "dodgerblue4", "darkgoldenrod2"))
axis(1, cex.axis=4)
axis(2, cex.axis=4, las=2)
mtext("Time (in Mya) from the molecular clock", 1, line=7, cex=4)
mtext("Time (in Mya) from our estimate", 2, line=9, cex=4)
legend("topleft", c(expression("T"[divergence]*" compare to mitochondrial data"), expression("T"[divergence]*" compare to nuclear data")), col=c("black", "gray60"), lty=c(1,1), lwd=3, cex=2, bty = "n")
dev.off()


library(netplot)
library(igraph)
set.seed(21)
n <- 100
data(UKfaculty, package = "igraphdata")

n <- vcount(UKfaculty)
nam <- sample(babynames::babynames$name, n)

ans <- nplot(
  UKfaculty,
  vertex.label      = nam,
  vertex.size.range = c(.01, .04, 4),
  vertex.label.col  =  "white",
  vertex.label.fontface = "bold",
  bg.col            = "black"
  )

ans$childrenOrder <- with(
  ans,
  c(
    childrenOrder[grepl("^edge[0-9]+[-][0-9]+$", childrenOrder)],
    childrenOrder[grepl("^vertex[.][0-9]+$", childrenOrder)],
    childrenOrder[grepl("^vertex-label[.][0-9]+$", childrenOrder)]
  ))

ans


rm(list=ls())
setwd("~/Documents/Filezilla downloads")

d <- read.csv("ELICIT_data_for_PLOS_reshaped_v2.csv", as.is=T)

head(d)
temp <- d[,c("pid", "obs_number", "impute_mthr_height", "mthr_height")]
unique(temp$obs_number[!is.na(temp$impute_mthr_height)])
#[1] 0
unique(temp$obs_number[!is.na(temp$mthr_height)])
#[1] 0

temp <- d[d$obs_number==0,c("pid", "obs_number", "impute_mthr_height", "mthr_height")]
temp[temp$impute_mthr_height!=temp$mthr_height & !is.na(temp$impute_mthr_height) & !is.na(temp$mthr_height),]

length(temp$pid[is.na(temp$impute_mthr_height)])
#[1] 0

length(temp$pid[is.na(temp$mthr_height)])
#[1] 79

d$is_mthr_height_imputed <- NA
d$is_mthr_height_imputed[d$obs_number==0 & is.na(d$mthr_height)] <- "yes"
d$is_mthr_height_imputed[d$obs_number==0 & !is.na(d$mthr_height)] <- "no"

length(d$is_mthr_height_imputed[d$is_mthr_height_imputed=="yes" & !is.na(d$is_mthr_height_imputed)])
unique(d$impute_mthr_height[d$is_mthr_height_imputed=="yes" & !is.na(d$is_mthr_height_imputed)])
unique(d$is_mthr_height_imputed[d$impute_mthr_height==157.3236 & !is.na(d$impute_mthr_height)])

####

d$is_mthr_weight_imputed <- NA
d$is_mthr_weight_imputed[d$obs_number==0 & is.na(d$mthr_weight)] <- "yes"
d$is_mthr_weight_imputed[d$obs_number==0 & !is.na(d$mthr_weight)] <- "no"

length(d$is_mthr_weight_imputed[d$is_mthr_weight_imputed=="yes" & !is.na(d$is_mthr_weight_imputed)])
unique(d$impute_mthr_weight[d$is_mthr_weight_imputed=="yes" & !is.na(d$is_mthr_weight_imputed)])
unique(d$is_mthr_weight_imputed[d$impute_mthr_weight==54.93949 & !is.na(d$impute_mthr_weight)])

####

write.csv(d, "ELICIT_data_for_PLOS_reshaped_v3.csv", row.names=F)


# big data bread R code
##### QUESTION FOR TAMMY: (Line 20) Why do we need to EXCLUDEEE zip code from tree predictor values????

# importing workingData (grocery stores, and median income of zipcodes) into a dataframe
groceryStores <- read.csv("moreWorkingData.csv", header=T, na.strings="?")
fix(groceryStores)
summary(groceryStores)
summary(groceryStores$ZipCode)
groceryStores

highAndLowGroceryStores <- groceryStores[groceryStores$NumberClassification != 2, ]
fix(highAndLowGroceryStores)

################################################
# Classification Trees
################################################

# make it into a classification tree
install.packages("tree")
library(tree)

# classification tree for predicting CLASSIFICTION of grocery stores (high/medium/low)
tree.classificationGroceryStores=tree(WordClassification ~ MeanIncomeForZipcode + PopulationOfZipcode, highAndLowGroceryStores)
summary(tree.classificationGroceryStores)
plot(tree.classificationGroceryStores)
text(tree.classificationGroceryStores)

# a perfect classifier should have a deviance of 0... but our deviance is 84.69369,
# ... so classification tree is probably not the way to go
deviance(tree.classificationGroceryStores)

# classification tree for predicting MEAN income per zipcode
tree.meanIncomePerZipcode=tree(Mean.Income.for.Zipcode ~. -Grocery.Store.Name -Address -Zip.Code -Nummber.Classification, groceryStores)
summary(tree.meanIncomePerZipcode)
plot(tree.meanIncomePerZipcode)
text(tree.meanIncomePerZipcode)

# ... nOT GOOD
yikes <- deviance(tree.meanIncomePerZipcode)

# attempt to predict zipcode ... doesn't work well
tree.zipcode=tree(ZipCode ~ WordClassification + MeanIncomeForZipcode + PopulationOfZipcode, highAndLowGroceryStores)
summary(tree.zipcode)
plot(tree.zipcode)
text(tree.zipcode)
summary(groceryStores$Zip.Code)

################################################
# Bayes Classifier
################################################

install.packages("e1071")
library(e1071)
help(naiveBayes)

# make a training set of a random sample that's half the size of the groceryStores data
set.seed(2)

#train=sample(1:nrow(highAndLowGroceryStores), 100) #need to play around with "train" data...
#groceryStores.test=highAndLowGroceryStores[-train,]
train=sample(1:nrow(groceryStores), 100)
groceryStores.test=groceryStores[-train,]

# NEED TO CHECK "TRAINING" DATA

#bay.c <- naiveBayes(WordClassification ~ MeanIncomeForZipcode + PopulationOfZipcode, highAndLowGroceryStores, subset=train)
bay.c <- naiveBayes(WordClassification ~ MeanIncomeForZipcode + PopulationOfZipcode, groceryStores, subset=train)
summary(bay.c)
bay.c

results <- predict(bay.c, groceryStores.test)
table(results,groceryStores.test$WordClassification)

################################################
# Regression Trees (with bagging!)
################################################
install.packages("randomForest")
library(randomForest)

train=sample(1:nrow(highAndLowGroceryStores), 101) #need to play around with "train" data...

# create a test-set
grocery.test=highAndLowGroceryStores[-train,"MeanIncomeForZipcode"]

# predict MEAN INCOME PER ZIPCODE with regression trees
set.seed(1)
bag.grocery=randomForest(MeanIncomeForZipcode ~ PopulationOfZipcode + WordClassification, data=highAndLowGroceryStores, subset=train, mtry=2, importance=TRUE)
bag.grocery
yhat.bag = predict(bag.grocery, newdata=highAndLowGroceryStores[-train,])
#yhat.bag = head(yhat.bag, -1)

plot(yhat.bag, grocery.test)
abline(0, 1)
mean((yhat.bag-grocery.test)^2) # mean squared error is 22-million LOL
yhat.bag
grocery.test
##### saved regression tree as LOL_regressionTreeNoThankYou_Yikes.pdf

# Median income per zipcode provides the most increase in MSE
importance(bag.grocery)
# Median income per zipcode ALSO is the most "pure" in nodes
varImpPlot(bag.grocery)

################################################
# Boosting things (Regression tree)
################################################

#### YIKES ---- only Multnomah county data == NOT ENOUGH DATA for boooooosting!!!!
#install.packages("gbm")
#library(gbm)
#set.seed(1)
#boost.grocery=gbm(Mean.Income.for.Zipcode ~. -Address -Grocery.Store.Name, data=groceryStores[train,], distribution="gaussian", n.trees=20, interaction.depth=4)
#summary(boost.grocery)

################################################
# Regression lines (with multiple regression!!!!!)
# NOT USING THIS --- because not relevant to groceryStores really... and it's not making robust models...
################################################

lm.fit=lm(MeanIncomeForZipcode ~ PopulationOfZipcode, data=groceryStores)
lm.fit
summary(lm.fit)

par(mfrow=c(2,2))
plot(lm.fit)

par(mfrow=c(1,1))
plot(MeanIncomeForZipcode ~ PopulationOfZipcode, groceryStores)
abline(lm.fit)
coef(lm.fit)
confint(lm.fit)

summary(lm.fit)

################################################
# Let'z K-meanz cluster dis
#
################################################
set.seed(2)
x <- groceryStores[,c(1, 3, 6, 7, 8)]

km.out=kmeans(x, 3, nstart=20)
km.out$cluster
km.out$centers

plot(x, col=(km.out$cluster+1), main="K-Means Clustering Results with K=3", pch=20, cex=2)

km.out$iter

###### TRY K-MEANS CLUSTERING
### change "classification" value columns (aka "High" to 1; "Medium" to 2; "Low" to 3)

################################################
# Hierarchical clusteringggg
# .... what does this meann!!!!????? it kind of worked
#
# ... not clean (especially with cutting)
################################################
hc.complete=hclust(dist(highAndLowGroceryStores), method="complete")
hc.average=hclust(dist(highAndLowGroceryStores), method="average")
hc.single=hclust(dist(highAndLowGroceryStores), method="single")

par(mfrow=c(1,3))
plot(hc.complete,main="Complete Linkage", xlab="", sub="", cex=.9)
plot(hc.average,main="Average Linkage", xlab="", sub="", cex=.9)
plot(hc.single,main="Single Linkage", xlab="", sub="", cex=.9)

cutree(hc.complete, 3)
cutree(hc.average, 3)
cutree(hc.single, 3)

################################################
# Principal components --- reduces the dimensionality of our dataset
################################################

groceryStoreIncomeAndPop <- groceryStores[,c(6, 7, 8)]

summary(groceryStoreIncomeAndPop)

apply(groceryStoreIncomeAndPop, 2, mean)
apply(groceryStoreIncomeAndPop, 2, var)

pr.out=prcomp(groceryStoreIncomeAndPop, scale=TRUE)
names(pr.out)
pr.out$center
pr.out$scale
pr.out$rotation
pr.out$x

biplot(pr.out, scale=1)

pr.out$rotation=-pr.out$rotation
pr.out$x=-pr.out$x
biplot(pr.out, scale=1)

pr.out$sdev
pr.var=pr.out$sdev^2
pr.var
pve=pr.var/sum(pr.var)
pve

# plot the (regular) proportion of variance (per Principal Component)
plot(pve, xlab="Principal Component", ylab="Proportion of Variance Explained", ylim=c(0,1), type='b')

# plot the cumulative proportion of variance
plot(cumsum(pve), xlab="Principle Component", ylab="Cumulative Proportion of Variance Explained", ylim=c(0,1),type='b')


#clearing the workspace
rm(list=ls())
graphics.off()
options(show.error.locations = TRUE)
require("ggplot2")

# If we are in a stand alone ubiquity distribution we run
# from there otherwise we try to load the package
if(file.exists(file.path('library', 'r_general', 'ubiquity.R'))){
  source(file.path('library', 'r_general', 'ubiquity.R'))
} else {
  library(ubiquity) }

# Creating the mAb system file
system_new(file_name="system.txt", system_file="mab_pk", overwrite = TRUE)

# For documentation explaining how to modify the commands below
# See the "R Workflow" section at the link below:
# http://presentation.ubiquity.grok.tv

# Rebuilding the system (R scripts and compiling C code)
cfg = build_system(output_directory     = file.path(".", "output"),
                   temporary_directory  = file.path(".", "transient"))

# set name                  | Description
# -------------------------------------------------------
# default                   | TMDD: Membrane bound target

cfg = system_select_set(cfg, "default")

# fetching the parameter values
parameters = system_fetch_parameters(cfg)

# The following applies to both individual and stochastic simulations:
# Define the solver to use
cfg=system_set_option(cfg,group = "simulation", option = "solver", value = "lsoda")
# Specify the output times
cfg=system_set_option(cfg, group  = "simulation",
                           option = "output_times",
                           seq(0,28*7*4,1))

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

# Same using titration
# Enabling titration
cfg=system_set_option(cfg,
                      group       = "titration",
                      option      = "titrate",
                      value       = TRUE)

# Creating a titration event
cfg=system_new_tt_rule(cfg,
                       name       = "ivdose",
                       times      = c(0, 6, 12, 18, 24),
                       timescale  = "months")

cfg=system_set_tt_cond(cfg,
                       name       = "ivdose",
                       cond       = "Cc < 900",
                       action     = "SI_TT_BOLUS[state='At', values=700, times=0, repdose='last', number=11, interval=14]",
                       value      = "700")

cfg=system_set_tt_cond(cfg,
                       name       = "ivdose",
                       cond       = "Cc > 900",
                       action     = "SI_TT_BOLUS[state='At', values=600, times=0, repdose='last', number=11, interval=14]",
                       value      = "600")

som_tt = run_simulation_titrate(parameters, cfg)

myfig = ggplot() +
        geom_line(data=som_tt$simout, aes(x=ts.weeks,   y=Cc), color="blue")

myfig = prepare_figure('present', myfig)

print(myfig)

ggsave(sprintf('output%svisit_titration.png', .Platform$file.sep), width=8, height=3.4, plot=myfig)


residuals.ivmodel <- function(object, ...){
  ivmodel <- object
  temp <- matrix(NA, nrow=2, ncol=0)
  if(!is.null(ivmodel$kClass)){
    temp<-rbind(as.numeric(rownames(ivmodel$kClass$ci)), c(ivmodel$kClass$point.est))
	colnames(temp) <- paste("k=", temp[1,], sep="")
    colnames(temp)[temp[1,]==0] <- "OLS"
    colnames(temp)[temp[1,]==1] <- "TSLS"
  }
  if(!is.null(ivmodel$LIML)){
    LIML <- c(ivmodel$LIML$k, ivmodel$LIML$point.est)
	temp <- cbind(temp, LIML)
  }
  if(!is.null(ivmodel$Fuller)){
    Fuller <- c(ivmodel$Fuller$k, ivmodel$Fuller$point.est)
	temp <- cbind(temp, Fuller)
  }

  result <- matrix(NA, ncol=ncol(temp), nrow=ivmodel$n)
  colnames(result) <- colnames(temp)
  for(i in 1:ncol(temp)){
    result[, i] <- ivmodel$Y - ivmodel$Yadj - temp[2, i]*(ivmodel$D-ivmodel$Dadj)
  }

  # NA handling
  output = matrix(NA, ncol=ncol(temp), nrow=length(ivmodel$naindex))
  colnames(output) <- colnames(temp)
  output[which(ivmodel$naindex), ] = result
  return(output)
}


# Author: Nikos Kougianos
# Date: 18/12/2020

# Use these 2 lines to set working directory as the current directory of the
# file. Tested on Rstudio @ Windows 10 OS.
this.dir <- dirname(parent.frame(2)$ofile)
setwd(this.dir);

# Read data
data <- read.table("data.csv", sep=",",header=TRUE)

# Create dataframe with 2 columns instead of 4
df <- data.frame('Plant_Height'=c(data$Plant.Height,data$Plant.Height.1), 'Geo_Position'=c(data$Geo.Position,data$Geo.Position.1))

# Create frequency histogram
frequency_histogram <- hist(df$Plant_Height, xlab="Plant height", main = "Frequency histogram of plant height")

# Create relative frequency histogram
relative_frequency_histogram <- hist(df$Plant_Height, freq=FALSE, xlab="Plant height", main = "Relative Frequency histogram of plant height")


REBOL [
  Title:   "Generates Red integer! tests"
	Author:  "Peter W A Wood"
	File: 	 %make-integer-auto-test.r
	Version: 0.1.0
	Tabs:	 4
	Rights:  "Copyright (C) 2011-2015 Peter W A Wood. All rights reserved."
	License: "BSD-3 - https://github.com/red/red/blob/origin/BSD-3-License.txt"
]

;; initialisations
tests: copy ""                          ;; string to hold generated tests
test-number: 0                          ;; number of the generated test
make-dir %auto-tests/
file-out: %auto-tests/integer-auto-test.red

;; create a block of values to be used in the binary ops tests
test-values: [
            0                   ; zero
  -2147483648                   ; min
   2147483647                   ; max
                                ;; DO NOT USE -1 as it crashes REBOL !!!!
            3
           -7
            5
       123456
        28230
        -6681
        44095
        65536
]

prefix-test-values: [
	0
	-2147483648                   	; min
	2147483647                   	; max
	1
]

;; create blocks of operators to be applied
test-binary-ops: [
  +
  -
  *
  /
  //
  ;or
  ;xor
  ;and
]

test-no-zeroes: [         ;; zero not allowed as operand2
  /
  //
]

test-prefix-ops: [
  add
  subtract
  multiply
  divide
  remainder
]

test-prefix-no-zeroes-ops: [
	divide
	remainder
]

test-comparison-ops: [
  =
  <>
  <
  >
  >=
  <=
]

test-comparison-values: [
  -1
  0
  +1
]

;; create test file with header
append tests "Red [^(0A)"
append tests {  Title:   "Red auto-generated integer! tests"^(0A)}
append tests {	Author:  "Peter W A Wood"^(0A)}
append tests {  File: 	 %integer-auto-test.red^(0A)}
append tests {  License: "BSD-3 - https://github.com/dockimbel/Red/blob/origin/BSD-3-License.txt"^(0A)}
append tests "]^(0A)^(0A)"
append tests "^(0A)^(0A)comment {"
append tests "  This file is generated by make-integer-auto-test.r^(0A)"
append tests "  Do not edit this file directly.^(0A)"
append tests "}^(0A)^(0A)"
append tests join ";make-length:"
                  [length? read %make-integer-auto-test.r "^(0A)^(0A)"]
append tests {#include  %../../../../quick-test/quick-test.red^(0A)^(0A)}
append tests {~~~start-file~~~ "Auto-generated tests for integers"^(0A)^(0A)}
append tests {===start-group=== "Auto-generated tests for integers"^(0A)^(0A)}

write file-out tests
tests: copy ""

;; binary operator tests - in global context
foreach op test-binary-ops [
  foreach operand1 test-values [
    foreach operand2 test-values [
      ;; only write a test if REBOL produces a result
      if attempt [expected: do reduce [operand1 op operand2]][

        ;; don't write tests for certain ops with zero second operand
        if not all [
          operand2 = 0
          find test-no-zeroes op
        ][
          expected: to-integer expected

          ;; convert REBOL's // operator to Red % operator
          nop: either op = first [//][#"%"][op]

          ;; test with literal values
          test-number: test-number + 1
          append tests join {  --test-- "integer-auto-} [test-number {"^(0A)}]
          append tests "  --assert "
          append tests reform [expected " = (" operand1 nop operand2 ")^(0A)"]

          ;; test with variables
          test-number: test-number + 1
          append tests join {  --test-- "integer-auto-} [test-number {"^(0A)}]
          append tests join "      i: " [operand1 "^(0A)"]
          append tests join "      j: " [operand2 "^(0A)"]
          append tests rejoin ["      k:  i " nop " j^(0A)"]
          append tests "  --assert "
          append tests reform [expected " = k ^(0A)"]

          ;; write tests to file
          write/append file-out tests
          tests: copy ""
        ]
      ]
      recycle
    ]
  ]
]

;; binary operator tests - inside a function

;; write function spec
append tests "  integer-auto-test-func: func [^(0A)"
;append tests "    return: [integer!]^(0A)"
append tests "      /local^(0A)"
append tests "      i [integer!]^(0A)"
append tests "      j [integer!]^(0A)"
append tests "      k [integer!]^(0A)"
append tests "    ][^(0A)"
write/append file-out tests
tests: copy ""

foreach op test-binary-ops [
  foreach operand1 test-values [
    foreach operand2 test-values [
      ;; only write a test if REBOL produces a result
      if attempt [expected: do reduce [operand1 op operand2]][

        ;; don't write tests for certain ops with zero second operand
        if not all [
          operand2 = 0
          find test-no-zeroes op
        ][
          expected: to-integer expected

          ;; convert REBOL's // operator to Red/System's % operator
          nop: either op = first [//][#"%"][op]

          ;; test with variables inside the function
          test-number: test-number + 1
          append tests join {    --test-- "integer-auto-} [test-number {"^(0A)}]
          append tests join "      i: " [operand1 "^(0A)"]
          append tests join "      j: " [operand2 "^(0A)"]
          append tests rejoin ["      k:  i " nop " j^(0A)"]
          append tests "    --assert "
          append tests reform [expected " = k ^(0A)"]

          ;; write tests to file
          write/append file-out tests
          tests: copy ""
        ]
      ]
      recycle
    ]
  ]
]

;; write closing bracket and function call
append tests "  ]^(0a)"
append tests "integer-auto-test-func^(0a)"
write/append file-out tests
tests: copy ""

;; prefix binary operator tests - in global context
foreach op test-prefix-ops [
  foreach operand1 prefix-test-values [
    foreach operand2 prefix-test-values [
      ;; only write a test if REBOL produces a result
      if attempt [expected: do reduce [op operand1 operand2]][

        ;; don't write tests for certain ops with zero second operand
        if not all [
          operand2 = 0
          find test-prefix-no-zeroes-ops op
        ][
          expected: to-integer expected

          ;; test with literal values
          test-number: test-number + 1
          append tests join {  --test-- "integer-auto-} [test-number {"^(0A)}]
          append tests "  --assert "
          append tests reform [expected " = (" op operand1 operand2 ")^(0A)"]

          ;; test with variables
          test-number: test-number + 1
          append tests join {  --test-- "integer-auto-} [test-number {"^(0A)}]
          append tests join "      i: " [operand1 "^(0A)"]
          append tests join "      j: " [operand2 "^(0A)"]
          append tests rejoin ["      k: " op " i j^(0A)"]
          append tests "  --assert "
          append tests reform [expected " = k ^(0A)"]

          ;; write tests to file
          write/append file-out tests
          tests: copy ""
        ]
      ]
      recycle
    ]
  ]
]

;; comparison tests
foreach op test-comparison-ops [
  foreach operand1 test-values [
    foreach operand2 test-comparison-values [
      ;; only write a test if REBOL produces a result
      if all [
        attempt [operand2: operand1 + operand2]
        none <> attempt [expected: do reduce [operand1 op operand2]]
      ][
        test-number: test-number + 1
        append tests join {  --test-- "integer-auto-} [test-number {"^(0A)}]
        append tests "  --assert "
        append tests reform [expected " = (" operand1 op operand2 ")^(0A)"]

        ;; write tests to file
        write/append file-out tests
        tests: copy ""
      ]
    ]
  ]
]

;; write file epilog
append tests "^(0A)===end-group===^(0A)^(0A)"
append tests {~~~end-file~~~^(0A)^(0A)}

write/append file-out tests

print ["Number of assertions generated" test-number]


pdf_file<-"pdf/timeseries_areas_between.pdf"
cairo_pdf(bg="grey98", pdf_file,width=11.69,height=8.27)

par(mai=c(1,1,0.5,0.5),omi=c(0,0.5,1,0),family="Lato Light",las=1)

# Import data and prepare chart

library(gdata)
rs<-read.xls("myData/B1_01.xls",1,header=F,encoding="latin1")
myColour1_150<-rgb(68,90,111,150,maxColorValue=255)
myColour1_50<-rgb(68,90,111,50,maxColorValue=255)
myColour2_150<-rgb(255,97,0,150,maxColorValue=255)
myColour2_50<-rgb(255,97,0,50,maxColorValue=255)
attach(rs)

# Define graphic and other elements

plot(V1,V11,axes=F,type="n",xlab="",ylab="Number (per 100 000 population)",cex.lab=1.5,xlim=c(1820,2020),ylim=c(10,40),xpd=T)
axis(1,at=c(1820,1870,1920,1970,2010))
axis(2,at=c(10,15,20,25,30,35,40),col=par("bg"),col.ticks="grey81",lwd.ticks=0.5,tck=-0.025)
lines(V1,V11,type="l",col=myColour1_150,lwd=3,xpd=T)
lines(V1,V12,type="l",col=myColour2_150,lwd=3)
text(1910,35,"Live births",adj=0,cex=1.5,col=myColour1_150)
text(1850,22,"Deaths",adj=0,cex=1.5,col=myColour2_150)
myBegin<-c(1817,1915,1919,1972); ende<-c(1914,1918,1971,2000)
myColour<-c(myColour1_50,myColour2_50,myColour1_50,myColour2_50)
for (i in 1:length(myBegin))
{
mySubset<-subset(rs,V1 >= myBegin[i] & V1 <= ende[i])
attach(mySubset)
xx<-c(mySubset$V1,rev(mySubset$V1)); yy<-c(mySubset$V11,rev(mySubset$V12))
polygon(xx,yy,col=myColour[i],border=F)
}

# Titling

mtext("Live births and deaths in Germany 1820-2001",3,line=1.5,adj=0,family="Lato Black",cex=2.2,outer=T)
mtext("Annual values",3,line=-0.75,adj=0,font=3,cex=1.8,outer=T)
mtext("Source: gesis.org/histat",1,line=3,adj=1,cex=1.2,font=3)
dev.off()


## This replication file
## makes the following tables and figures:
# Figure 5

# Packages
library(MatchIt)
library(lmtest)
library(sandwich)
library(tidyverse)

##
# Figure 5
##

#savepdf <- function(file, width=7.28, height=3.54){ # 3.46, 1.77
#    fname <- paste("",file,".pdf",sep="")
#    pdf(fname, width=width, height=height,
#        pointsize=7)
#    par(mgp=c(2.2,0.45,0), tcl=-0.4, mar=c(3.3,3.6,1.1,1.1))
#}

#savepdf("output/Fukumoto_Fig5")

p_path <- "../Fukumoto2021/preprocess/preprocess.0406.R"
m_path <- "../Fukumoto2021/matching_results/alt_att_0406_1000_1000.RDS"
source("gen.0406.att_beta.R")

plot(YMD[part.adj], average.C2, col = 2, lty = 2,
     xlim=c(YMD[part.adj[1]], YMD[part.adj[length(part.adj)]]),
     xlab="Day", ylab="Outcome",
     type="l",
     main = paste("Outcome (April 6): ", reduction*100, "% mitigating effect"),
     ylim=c(0,1))
lines(YMD[part.adj], average.C2, col = 2, lty = 1)
lines(YMD[part.adj], average.T2, lty = 1)
#lines(YMD[part.adj], average.all.T2[part.adj], lty = 2)
abline(v=YMD[part.adj[8]], col = "turquoise") # April 6

plot(YMD[part.adj], summary.Match.out2[, 1],
     xlim=c(YMD[part.adj[1]], YMD[part.adj[length(part.adj)]]),
     ylim=c(-0.5,0.5),
     main = "ATT",
     xlab="Day", ylab="ATT",
     type="l")
polygon(c(YMD[part.adj], rev(YMD[part.adj])), c(UB2, rev(LB2)), col = shadecolor, border = NA)
lines(YMD[part.adj], summary.Match.out2[, 1], col = 1, lty = 1, lwd = 3)
abline(v=YMD[part.adj[8]], col = "turquoise") # April 6
abline(0,0,lty=2)

# Fukumoto_Fig5_a_source
Fukumoto_Fig5_a <- cbind(as.character(YMD[part.adj]), average.C2, average.T2, average.all.T2[part.adj])
colnames(Fukumoto_Fig5_a) <- c("date", "outcome average in matched control municipalities", "outcome average in matched treated municipalities",
                               "outcome average in all treated municipalities")
write.csv(Fukumoto_Fig5_a, "../output/Fukumoto_Fig5_a_beta_source.csv", row.names = FALSE)

# Fukumoto_Fig5_b_source
Fukumoto_Fig5_b <- cbind(as.character(YMD[part.adj]), summary.Match.out2[, 1], LB2, UB2)
colnames(Fukumoto_Fig5_b) <- c("date", "ATC", "lower bound of 95% confidence interval",
                               "upper bound of 95% confidence interval")
write.csv(Fukumoto_Fig5_b, "../output/Fukumoto_Fig5_b_beta_source.csv", row.names = FALSE)


suppressPackageStartupMessages(library(dplyr))
suppressPackageStartupMessages(library(broom))
suppressPackageStartupMessages(library(ggplot2))
suppressPackageStartupMessages(library(ggrepel))

source(file.path("scripts", "signature_utils.R"))

col_types <- readr::cols(
    .default = readr::col_double(),
    Metadata_CellLine = readr::col_character(),
    Metadata_Dosage = readr::col_double(),
    Metadata_Plate = readr::col_character(),
    Metadata_Well = readr::col_character(),
    Metadata_batch = readr::col_character(),
    Metadata_plate_map_name = readr::col_character(),
    Metadata_clone_type = readr::col_character()
)

profile_dir <- file.path("..", "2.describe-data", "data", "merged")
profile_file <- file.path(profile_dir, "combined_cloneAcloneE_dataset_feature_select.csv")

# Load Data and subset to only untreated samples
cloneAE_data_df <- readr::read_csv(profile_file, col_types = col_types) %>%
    dplyr::filter(Metadata_Dosage == 0)

print(dim(cloneAE_data_df))
head(cloneAE_data_df, 3)

table(
    cloneAE_data_df$Metadata_batch,
    cloneAE_data_df$Metadata_CellLine,
    cloneAE_data_df$Metadata_Dosage
    )

cloneAE_formula_terms <- paste(
    "~",
    "Metadata_clone_type", "+",
    "Metadata_batch", "+",
    "Metadata_Plate", "+",
    "Metadata_CellLine"
)

cloneAE_full_results <- perform_anova(cloneAE_data_df, cloneAE_formula_terms)

cloneAE_full_results_df <- cloneAE_full_results[["full_results_df"]]

cloneAE_full_results_df$term <- factor(
    cloneAE_full_results_df$term, levels = c(
        "Metadata_batch",
        "Metadata_Plate",
        "Metadata_CellLine",
        "Metadata_clone_type"
    )
)

cloneAE_full_results_df <- cloneAE_full_results_df %>%
    dplyr::arrange(desc(neg_log_p))

print(dim(cloneAE_full_results_df))
head(cloneAE_full_results_df, 6)

cloneAE_aov <- cloneAE_full_results[["aovs"]]
full_tukey_results_df <- process_tukey(cloneAE_aov, unique(cloneAE_full_results_df$feature))

print(dim(full_tukey_results_df))
head(full_tukey_results_df)

num_cp_features <- length(unique(cloneAE_full_results_df$feature))

difference_contribution_gg <- ggplot(cloneAE_full_results_df,
                                     aes(x = neg_log_p)) +
    geom_density(aes(fill = term), alpha = 0.4) +
    theme_bw() +
    xlab("-log10 p value") +
    ylab("") +
    ggtitle(
        paste("Comparing Clone A, E, and Wildtype\nANOVA effects for all",
               num_cp_features,
              "CP features")) +
    theme(axis.text = element_text(size = 6),
          axis.title = element_text(size = 7),
          title = element_text(size = 8))

out_file <- file.path("figures", "cloneAE_anova_effect_term_distributions.png")
ggsave(out_file, dpi = 500, height = 5, width = 4)

difference_contribution_gg

difference_contribution_gg <- ggplot(cloneAE_full_results_df %>% dplyr::filter(neg_log_p < 200),
                                     aes(x = neg_log_p)) +
    geom_density(aes(fill = term), alpha = 0.4) +
    theme_bw() +
    xlab("-log10 p value") +
    ylab("") +
    ggtitle(
        paste("Comparing Clone A, E, and Wildtype\nANOVA effects for all",
               num_cp_features,
              "CP features")) +
    theme(axis.text = element_text(size = 6),
          axis.title = element_text(size = 7),
          title = element_text(size = 8))

out_file <- file.path("figures", "cloneAE_anova_effect_term_distributions_cutoff.png")
ggsave(out_file, dpi = 500, height = 5, width = 4)

difference_contribution_gg

signif_line <- -log10(0.05 / nrow(full_tukey_results_df))

tukey_volcano_gg <- ggplot(full_tukey_results_df, aes(x = estimate, y = neg_log_p)) +
    geom_point(aes(color = comparison)) +
    geom_hline(yintercept = signif_line, color="red", linetype="dashed") +
    facet_wrap("~term", nrow=length(unique(full_tukey_results_df$term))) +
    theme_bw() +
    xlab("Statistic") +
    ylab("-log10 P Value") +
    theme(strip.text = element_text(size = 8, color = "black"),
          strip.background = element_rect(colour = "black", fill = "#fdfff4"))

out_file <- file.path("figures", "cloneAE_tukey_volcano.png")
ggsave(out_file, dpi = 500, height = 5, width = 6)

tukey_volcano_gg

feature_exclude_batch <- full_tukey_results_df %>%
    dplyr::filter(term == "Metadata_batch", neg_log_p > !!signif_line) %>%
    dplyr::pull(feature)

feature_exclude_cellline <- full_tukey_results_df %>%
    dplyr::filter(term == "Metadata_CellLine", neg_log_p > !!signif_line) %>%
    dplyr::pull(feature)

signature_features <- full_tukey_results_df %>%
    dplyr::filter(term == "Metadata_clone_type", neg_log_p > !!signif_line) %>%
    dplyr::pull(feature)

signature_features <- setdiff(signature_features, feature_exclude_cellline)
signature_features <- setdiff(signature_features, feature_exclude_batch)

signature_features <- sort(signature_features)

cloneAE_signature_df <- full_tukey_results_df %>%
    dplyr::filter(feature %in% signature_features,
                  term == "Metadata_clone_type")

output_file <- file.path("results", "cloneAE_signature_tukey.tsv")
cloneAE_signature_df %>% readr::write_tsv(output_file)

cloneAE_signature_df

col_types <- readr::cols(
    .default = readr::col_double(),
    Metadata_Plate = readr::col_character(),
    Metadata_Well = readr::col_character(),
    Metadata_plate_map_name = readr::col_character(),
    Metadata_clone_number = readr::col_character(),
    Metadata_clone_type = readr::col_character(),
    Metadata_plate_ID = readr::col_character(),
    Metadata_plate_filename = readr::col_character(),
    Metadata_treatment = readr::col_character(),
    Metadata_batch = readr::col_character()
)

profile_dir <- file.path("..", "2.describe-data", "data", "merged")
profile_file <- file.path(profile_dir, "combined_four_clone_dataset_feature_select.csv")

# Select only DMSO treatment
fourclone_data_df <- readr::read_csv(profile_file, col_types = col_types) %>%
    dplyr::filter(Metadata_treatment == "DMSO")

print(dim(fourclone_data_df))
head(fourclone_data_df)

table(
    fourclone_data_df$Metadata_clone_number,
    fourclone_data_df$Metadata_clone_type,
    fourclone_data_df$Metadata_treatment,
    fourclone_data_df$Metadata_batch
)

four_clone_formula_terms <- paste(
    "~",
    "Metadata_clone_type", "+",
    "Metadata_batch", "+",
    "Metadata_clone_number"
)

full_results <- perform_anova(fourclone_data_df, four_clone_formula_terms)

full_results_df <- full_results[["full_results_df"]]

full_results_df$term <- factor(
    full_results_df$term, levels = c(
        "Metadata_batch",
        "Metadata_clone_number",
        "Metadata_clone_type"
    )
)

full_results_df <- full_results_df %>%
    dplyr::arrange(desc(neg_log_p))

print(dim(full_results_df))
head(full_results_df, 6)

fourclone_aov <- full_results[["aovs"]]
full_tukey_results_df <- process_tukey(fourclone_aov, unique(full_results_df$feature))

print(dim(full_tukey_results_df))
head(full_tukey_results_df)

num_cp_features <- length(unique(full_results_df$feature))

difference_contribution_gg <- ggplot(full_results_df,
                                     aes(x = neg_log_p)) +
    geom_density(aes(fill = term), alpha = 0.4) +
    theme_bw() +
    xlab("-log10 p value") +
    ylab("") +
    ggtitle(
        paste("Comparing Four Wildtype and Resistant Clones\nANOVA effects for all",
               num_cp_features,
              "CP features")) +
    theme(axis.text = element_text(size = 6),
          axis.title = element_text(size = 7),
          title = element_text(size = 8))

out_file <- file.path("figures", "fourclone_anova_effect_term_distributions.png")
ggsave(out_file, dpi = 500, height = 3.5, width = 4)

difference_contribution_gg

signif_line <- -log10(0.05 / nrow(full_tukey_results_df))

tukey_volcano_gg <- ggplot(full_tukey_results_df, aes(x = estimate, y = neg_log_p)) +
    geom_point(aes(color = comparison)) +
    geom_hline(yintercept = signif_line, color="red", linetype="dashed") +
    facet_wrap("~term", nrow=length(unique(full_tukey_results_df$term))) +
    theme_bw() +
    xlab("Statistic") +
    ylab("-log10 P Value") +
    theme(strip.text = element_text(size = 8, color = "black"),
          strip.background = element_rect(colour = "black", fill = "#fdfff4")) +
    theme(legend.position = "none")

out_file <- file.path("figures", "fourclone_tukey_volcano.png")
ggsave(out_file, dpi = 500, height = 5, width = 4)

tukey_volcano_gg

# We want to exclude same clone-type comparisons, but not different clone type comparisons
clone_comparisons <- unique(
    full_tukey_results_df %>%
        dplyr::filter(term == "Metadata_clone_number") %>%
        dplyr::pull(comparison)
    )

same_clonetype_compare <- c(
    'BZ008-BZ001', 'BZ017-BZ001', 'BZ018-BZ001', 'BZ017-BZ008',
    'BZ018-BZ008', 'BZ018-BZ017', 'WT002-WT_parental', 'WT008-WT_parental',
    'WT009-WT_parental', 'WT011-WT_parental', 'WT008-WT002', 'WT009-WT002',
    'WT011-WT002', 'WT009-WT008', 'WT011-WT008', 'WT011-WT009'
)

setdiff(clone_comparisons, same_clonetype_compare)

feature_exclude_batch <- full_tukey_results_df %>%
    dplyr::filter(term == "Metadata_batch", neg_log_p > !!signif_line) %>%
    dplyr::pull(feature)

feature_exclude_cellline <- full_tukey_results_df %>%
    dplyr::filter(term == "Metadata_clone_number",
                  comparison %in% same_clonetype_compare,
                  neg_log_p > !!signif_line) %>%
    dplyr::pull(feature)

signature_features <- full_tukey_results_df %>%
    dplyr::filter(term == "Metadata_clone_type", neg_log_p > !!signif_line) %>%
    dplyr::pull(feature)

signature_features <- setdiff(signature_features, feature_exclude_cellline)
signature_features <- setdiff(signature_features, feature_exclude_batch)

signature_features <- sort(signature_features)

signature_df <- full_tukey_results_df %>%
    dplyr::filter(feature %in% signature_features,
                  term == "Metadata_clone_type")

output_file <- file.path("results", "fourclone_signature_tukey.tsv")
signature_df %>% readr::write_tsv(output_file)

signature_df

feature_focus_df <- full_results_df %>%
    reshape2::dcast(feature ~ term, value.var = "neg_log_p")

head(feature_focus_df)

label_logic <- (
    (
        feature_focus_df$Metadata_clone_type > 20
    ) | (
        feature_focus_df$Metadata_clone_number > 20
    )
    )

feature_interpret_gg <- ggplot(feature_focus_df,
       aes(x = Metadata_clone_type,
           y = Metadata_clone_number,
           size = Metadata_batch)) +
    geom_point(alpha = 0.7) +
    geom_text_repel(data = subset(feature_focus_df, label_logic),
                    arrow = arrow(length = unit(0.01, "npc")),
                    box.padding = 0.7,
                    point.padding = 0.2,
                    segment.size = 0.5,
                    segment.alpha = 0.9,
                    size = 1.45,
                    fontface = "italic",
                    aes(label = feature,
                        x = Metadata_clone_type,
                        y = Metadata_clone_number)) +
    scale_size_continuous(name = "Batch effect", range = c(0.1, 3)) +
    theme_bw() +
    theme(axis.text = element_text(size = 6),
          axis.title = element_text(size = 7))

out_file <- file.path("figures", "fourclone_anova_effect_term_features_clone_vs_treatment.png")
ggsave(out_file, dpi = 400, height = 5, width = 5)

feature_interpret_gg

combined_gg <- process_signature_features(
    signature_df, plot_title = "Four Clone Resistance Signature", visualize_metric="Max"
)

output_file <- file.path("figures", "fourclone_signature_feature_interpret.png")
cowplot::save_plot(output_file, combined_gg, base_height = 5, base_width = 6, dpi = 500)

combined_gg

combined_gg <- process_signature_features(
    cloneAE_signature_df, plot_title = "Clone A and E Resistance Signature", visualize_metric="Max"
)

output_file <- file.path("figures", "cloneAE_signature_feature_interpret.png")
cowplot::save_plot(output_file, combined_gg, base_height = 5, base_width = 6, dpi = 500)

combined_gg


pdf_file<-"pdf/timeseries_with_trend_3x1_inc.pdf"
cairo_pdf(bg="grey98", pdf_file,width=11,height=9.5)

par(mfcol=c(3,1),cex.axis=1.4,mgp=c(5,1,0),family="Lato Light",las=1)
par(omi=c(0.5,0.5,1.1,0.5),mai=c(0,2,0,0.5))

# Prepare chart and import data

myColour1_150<-rgb(68,90,111,150,maxColorValue=255)
myColour1_50<-rgb(68,90,111,50,maxColorValue=255)
myColour2_150<-rgb(255,97,0,150,maxColorValue=255)
myColour2_50<-rgb(255,97,0,50,maxColorValue=255)

library(gdata)
myData<-read.xls("myData/z8053.xlsx", encoding="latin1")
attach(myData)

# Define graphic and other elements

par(mai=c(0,1.0,0.25,0))
plot(year,marriage,axes=F,type="n",xlab="",ylab="number (per 100 thousand)",cex.lab=1.5,xlim=c(1820,1920),ylim=c(700,1000),xpd=T)
axis(2,at=py<-c(700,800,900,1000),labels=format(py,big.mark=","),col=par("bg"),col.ticks="grey81",lwd.ticks=0.5,tck=-0.025)
lines(year,marriage,type="l",col=myColour1_150,lwd=3,xpd=T)
lines(year,marriagetrend,type="l",col=myColour1_50,lwd=10)
text(1910,880,"marriages with trend",cex=1.5,col=myColour1_150)

par(mai=c(0,1.0,0,0))
plot(year,agricultural,axes=F,type="n",xlab="",ylab="index",cex.lab=1.5,xlim=c(1820,1920),ylim=c(40,130))
axis(4,at=c(40,70,100,130),col=par("bg"),col.ticks="grey81",lwd.ticks=0.5,tck=-0.025)
lines(year,agricultural,type="l",col=myColour2_150,lwd=3)
lines(year,agriculturaltrend,type="l",col=myColour2_50,lwd=10)
text(1910,125,"agricultural prices with trend",cex=1.5,col=myColour2_150,xpd=T,)
text(1913,60,"1913=100",cex=1.5,col=rgb(100,100,100,maxColorValue=255))

arrows(1913,68,1913,90,length=0.10,angle=10,code=0,lwd=2,col=rgb(100,100,100,maxColorValue=255))
points(1913,100,pch=19,col="white",cex=3.5)
points(1913,100,pch=1,col=rgb(25,25,25,200,maxColorValue=255),cex=3.5)
points(1913,100,pch=19,col=rgb(25,25,25,200,maxColorValue=255),cex=2.5)

par(mai=c(0.5,1.0,0,0))
plot(year,marriagez,axes=F,type="n",xlab="",ylab="deviations",cex.lab=1.5,xlim=c(1820,1920),ylim=c(-70,70))
axis(1,at=pretty(year))
axis(2,at=c(-60,-30,0,30,60),col=par("bg"),col.ticks="grey81",lwd.ticks=0.5,tck=-0.025)
rect(1820,-70,1867,70,border=F,col="grey90")
lines(year,marriagez,type="l",col=myColour1_150,lwd=3)
lines(year,agriculturalz,type="l",col=myColour2_150,lwd=3)
text(1910,-40,"marriages",col=myColour1_150,cex=1.5)
text(1910,40,"agricultural prices ",col=myColour2_150,cex=1.5)

# Titling

mtext("Growth Trends and Economic Cycles",3,adj=0.5,line=3,cex=2.1,outer=T,family="Lato Black")
mtext("Annual Figures",3,adj=0.06,line=0,cex=1.75,outer=T,font=3)
dev.off()


########################################################################################
# # This code is a part of the data analysis in the Smartphone Lifequality article.  # #
# # The code inspects the different questions on the questionairs, and finds the     # #
# # relationships between the different features.                                    # #
# # Created by Dr. Alon Sela 24.7.2019                                               # #
# # For questions you can contact me al alonse@ariel.c.il                            # #
########################################################################################
install.packages("Rtools")
install.packages("clmm2")
install.packages("readstata13")
install.packages("pheatmap")
install.packages("glm")
install.packages("lme4")
## load package
library(pheatmap)
library(readstata13)
library(lme4)

# setwd("../data/")
a<-Sys.info()
MYPATH<-dirname(rstudioapi::getSourceEditorContext()$path)
setwd(MYPATH)
dat<-read.csv(file = "../data/results3.9 withCorrelations.csv", header = TRUE, stringsAsFactors = FALSE, )

dat<-read.csv(file = "E:/dropbox/Dropbox/_WORK_IN_PROGRESS/Smartphone H bengal/2019/data/results3.9 withCorrelations.csv", header = TRUE, stringsAsFactors = FALSE, )
header<-colnames(dat)
df2<-dat
# Change variable to ordered var
# ordrd_df2<-ordered(df2)
# Normalize sum of "well being" factors
df2$sum<-(round(as.numeric(dat$sum) / 10))
#
df2$sum<-ordered(df2$sum, levels = c(0,1 ,2 ,3, 4, 5, 6, 7, 8, 9))
colnames(df2) <- header

# compute spearman ranked correlation matrix for variable 1:16 vs 39
dt<-as.data.frame(c())
for (j in 1:38){
  a<-c()
  for (i in 1:38){
    a<-c(a,cor(as.numeric(df2[,i]), as.numeric(df2[,j]), use = "complete.obs", method="spearman"))
  }
  dt<-rbind(dt,a)
}
#check absolute value of corelations.
#dt<-abs(dt)

mat_dt<-as.matrix(dt)

colnames(mat_dt) <- c(header)
row.names(mat_dt) <- c(header)

# First heatmap - all questions
heatmap(t(mat_dt[1:37, 1:37]),
        labRow = rownames(mat_dt),
        labCol = header,
        hclustfun = hclust,
        symm = TRUE, margins = c(20,20),
        cexRow = 0.5,
        cexCol = 0.5)

# Second heatmap - Only Smartphone use on Life Quality effect
mat_short<-mat_dt[1:15,16:37]

heatmap(t(mat_short),
        labRow = rownames(mat_short),
        labCol = colnames(mat_short),
        symm = FALSE, margins = c(13,13),
        cexRow = 0.9)

# Separates to two components according to the hirarchical clusteirng analysis
# We name these clusters, the "Latent" and the "Concious" clusters of factors.

Latent <- (df2$Do.you.use.your.smartphone.in.parallel.with.other.activities...driving..cooking...TV. +
           df2$How.many.apps.you.have.in.your.smartphone. +
           df2$Do.you.go.to.bed.with.the.smartphonephone.at.your.side. +
           df2$Do.you.use.your.smartphone.in.the.middle.of.the.night. +
           df2$Do.you.consider.yourself.as.addicted.to.the.use.of.the.smartphone.) / 5
Concious<-(df2$Do.you.consider.the.smartphone.an.indispensable.tool.for.your.work.+
           df2$Do.you.consider.the.smartphon.an.indispensable.tool.for.your.social.life.+
           df2$Do.you.take.your.smartphone.with.you.to.the.restroom.+
           df2$How.many.social.networks..e.g..facebook..twitter..are..on.your.smartphone.+
           df2$how.many.socia.netowrks.apps+
           df2$Do.you.use.the.location.based.services.of.the.smartphone.+
           df2$For.how.long.have.you.had.a.smartphone.+
           df2$How.many.apps.you.have.in.your.smartphone.+
           df2$How.often.do.you.change.your.smartphone.+
           df2$Do.you.use.your.smartphone.camera..calculator..notes..reading.book..payments.) / 10

# binds the Latent cluster, the Concious cluster, and the Lfe Quality results into a single data frame.
reg_table<-as.data.frame(cbind(dat$sum, Concious, Latent, deparse.level = 1))
colnames(reg_table) <- c("LifeQuality","Concious", "Latent")
# Thre were only a few NA in the data, but these were removed.
reg_table<-na.omit(reg_table)
# Normalize to Unit size in order to find a true slope in the regression
normalize <- function(x) {
  return ((x - min(x)) / (max(x) - min(x)))
}
reg_table$LifeQuality <- normalize(reg_table$LifeQuality)
reg_table$Concious<-normalize(reg_table$Concious)
reg_table$Latent<-normalize(reg_table$Latent)
#Histogram of Life_quality measure
plot.new()
hist(reg_table$LifeQuality, breaks = 30, xlab = "Life_Quality (Normalized)", main = "Life Quality Distribution")
med<-median(reg_table$LifeQuality)
#med<-0.4
abline(v=med, col="red", lwd=3, lty=2)

# # create a boolean measure of life quality above / below median
# reg_table_latent$LifeQualityBoolean<-reg_table_latent$LifeQuality <= med

# simple regresson analysis
linearMod <- lm(LifeQuality ~ Concious + Latent, data=reg_table)
summary(linearMod)

# simple regresson analysis
linearMod <- lm(LifeQuality ~ Concious + Latent, data=reg_table)
summary(linearMod)

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


context("Test dataDiagnostics")

# Create data
n <- 15000 #size of dataset
nyr <- 20 # number of years in data
nSamples <- 100 # set number of dates
nSites <- 50 # set number of sites
set.seed(125)

# Create somes dates
first <- as.Date(strptime("2010/01/01", "%Y/%m/%d"))
last <- as.Date(strptime(paste(2010+(nyr-1),"/12/31", sep=''), "%Y/%m/%d"))
dt <- last-first
rDates <- first + (runif(nSamples)*dt)

# taxa are set as random letters
taxa <- sample(letters, size = n, TRUE)

# three sites are visited randomly
site <- sample(paste('A', 1:nSites, sep=''), size = n, TRUE)

# the date of visit is selected at random from those created earlier
time_period <- sample(rDates, size = n, TRUE)

df <- data.frame(taxa, site, time_period)

test_that("Test dataDiagnostics", {

 suppressWarnings(results <- dataDiagnostics(taxa = df$taxa,
                            progress_bar = FALSE,
                            site = df$site,
                            time_period = df$time_period,
                            plot = FALSE))

 recperyear <- structure(c(771L, 775L, 882L, 303L, 443L, 1051L, 582L, 862L,
             591L, 324L, 768L, 751L, 728L, 924L, 739L, 900L, 738L, 939L, 1185L,
             744L), .Dim = 20L, .Dimnames = structure(list(RecordsPerYear = c("2010",
                                                                              "2011", "2012", "2013", "2014", "2015", "2016", "2017", "2018",
                                                                              "2019", "2020", "2021", "2022", "2023", "2024", "2025", "2026",
                                                                              "2027", "2028", "2029")), .Names = "RecordsPerYear"), class = "table")
 visittop50 <- structure(list(time_period = structure(c(14657, 14657, 14657,
                                                        14657, 14657, 14657, 14657, 14657, 14657, 14657, 14657, 14657,
                                                        14657, 14657, 14657, 14657, 14657, 14657, 14657, 14657, 14657,
                                                        14657, 14657, 14657, 14657, 14657, 14657, 14657, 14657, 14657,
                                                        14657, 14657, 14657, 14657, 14657, 14657, 14657, 14657, 14657,
                                                        14657, 14657, 14657, 14657, 14657, 14657, 14657, 14657, 14713,
                                                        14713, 14713), class = "Date"),
                              site = c("A1", "A11", "A12",
                                       "A13", "A14", "A15", "A16", "A17", "A18", "A19", "A2", "A20",
                                       "A21", "A22", "A23", "A24", "A25", "A26", "A27", "A28", "A29",
                                       "A3", "A30", "A31", "A32", "A33", "A34", "A35", "A36", "A37",
                                       "A38", "A4", "A40", "A41", "A42", "A44", "A45", "A46", "A47",
                                       "A48", "A49", "A5", "A50", "A6", "A7", "A8", "A9", "A1", "A10",
                                       "A11"),
                              listLength = c(1L, 5L, 5L, 1L, 3L, 3L, 1L, 1L, 1L, 2L,
                                             2L, 5L, 6L, 4L, 1L, 5L, 1L, 5L, 4L, 5L, 3L, 7L, 2L, 4L, 5L, 2L,
                                             2L, 5L, 1L, 6L, 5L, 1L, 2L, 2L, 4L, 3L, 3L, 3L, 2L, 1L, 5L, 2L,
                                             1L, 5L, 2L, 2L, 3L, 5L, 5L, 1L)),
                              row.names = c(NA, 50L),
                              class = "data.frame")

 coefModRecs <- structure(c(-26329.52105, 13.40902), .Names = c("(Intercept)",
                                                              "time_period"))
 coefModVis <- structure(c(1.088671e+00, 6.040089e-07), .Names = c("(Intercept)",
                                                                               "time_period"))

 expect_equal(recperyear, results$RecordsPerYear)
 expect_equal(visittop50, results$VisitListLength[1:50,])
 expect_equal(coefModRecs, coefficients(results$modelRecs))
 expect_equal(coefModVis, coefficients(results$modelList), tolerance = 1e-6)

})


args <- commandArgs()
print(args)
lf <- read.csv(args[5],sep=",",check.names=FALSE)
lb <- read.csv(args[6],sep=",",check.names=FALSE)
colnames(lf) <- "a"
colnames(lb) <- "a"
pdf(file=args[7])
p=seq(0,1,0.01);
maxY = max(lf$a, lb$a)
r=quantile(lf$a,probs=p);
q=quantile(lb$a,probs=p);
plot(p,r,ylim=c(0,maxY),type="l",xlab="percent",ylab="latency(cycles)",col="blue", main=args[8]);
lines(p,q,col="red")
legend('topleft', c("lf","lb") , lty=1, col=c('blue', 'red'), bty='n', cex=.75)
dev.off()