source('hmm_v2.r')
source('constants.r')
source('backtest_lib.r')

test_HMMM <- function (env, symbols, time_interval, num_states){

#     env <- global_tables
#     symbol = "BNS"
#     time_interval = 5
#     num_states = 4

  N <- 135 #number of days where data is available

  num_sym <- length(symbols)
  Tnum = 23400 / (time_interval * 60)

  N_training = 90
  training_days <- c(1:N_training)

  num_var <- 3

  interval_volume_lamdas <- rep(0, num_sym)
  p_absolute_lamdas <- rep(0, num_sym)

  delta_p <- array(0, c(num_sym, N, Tnum))
  training_data <- array(0, c(num_var * num_sym, N_training, Tnum))
  for (sym in 1:num_sym){
    symbol <- symbols[sym]
    train_data <- get_data(env, symbol, time_interval)
    p_increments <- data.matrix(train_data[["p_increments"]])
    interval_volume <- data.matrix(train_data[["interval_volume"]])
    p_absolute <- data.matrix(train_data[["p_absolute"]])
    interval_volume_lamdas[sym] <- train_data[["Boxcoxlambda_interval_volume"]]
    p_absolute_lamdas[sym] <- train_data[["Boxcoxlambda_p_absolute"]]
    delta_p[sym,,] <- p_increments

    #qqnorm(as.vector(log(interval_volume[1:60,])))
    p_increments_training <- p_increments[training_days,]
    volume_training <- interval_volume[training_days,]
    p_absolute_training <- p_absolute[training_days,]

    training_data[(sym - 1) * num_var + 1,,] <- p_increments_training
    training_data[(sym - 1) * num_var + 2,,] <- volume_training
    training_data[(sym - 1) * num_var + 3,,] <- p_absolute_training
  }

  cat('get parameter estimates \n')

  estimates <- get_params_estimates(training_data, num_var * num_sym, num_states)

  A <- matrix(data.matrix(estimates[["A"]]), nrow = num_states, ncol = num_states)
  mu <- data.matrix(estimates[["mu"]])
  cov_mat <- array(data.matrix(estimates[["cov_matrix"]]), c(num_var * num_sym, num_var * num_sym, num_states))

  start_time <- as.POSIXct('2015-05-13 9:30:00 EDT')
  end_time <- as.POSIXct('2015-11-23 16:00:00 EDT')

  cat('run performance testing \n')
  system.time({performance_results <- performance_test(start_time, end_time, env, symbols, time_interval, num_states, num_var, A, mu, cov_mat, interval_volume_lamdas, p_absolute_lamdas)})

  predictions_temp <- data.matrix(performance_results[["predictions"]])
  eod_values <- data.matrix(performance_results[["eod_values"]])
  num_days <- length(eod_values)
  predictions <- array(predictions_temp, c(num_sym, num_days, Tnum))
  accuracy <- rep(0, num_sym)
  for (sym in 1:num_sym){
    prediction_sym <- predictions[sym,,]
    actual_directions <- matrix(NA, nrow(prediction_sym), Tnum)
    for (i in 1:nrow(prediction_sym)){
      for (t in 1:Tnum){
        if (delta_p[sym,i,t] > 0){
          actual_directions[i,t] = TRUE
        }
        else if(delta_p[sym,i,t] < 0){
          actual_directions[i,t] = FALSE
        }
        else{

        }
      }
    }
    temp_ind <- !is.na(prediction_sym)
    actual_d2 <- actual_directions[1:nrow(prediction_sym),]
    comparison <- prediction_sym[temp_ind] == actual_d2[temp_ind]
    accuracy[sym] <- sum(comparison[!is.na(comparison)]) / length(comparison)
  }

  eod_vals <- performance_results[["eod_values"]]
  rtn_lst <- list(accuracy, eod_vals, A, mu, cov_mat)
  names(rtn_lst) <- c("accuracy", "eod_results",'A', 'mu', 'cov_matrix')
  return(rtn_lst)
}

get_data <- function(env, symbol, time_interval)
{
  datatable_name <- paste(symbol, Con_Data_Tick_Suffix, sep = "")
  timestamp <- env[[datatable_name]][[Con_Data_ColName_Date]]
  value <- env[[datatable_name]][[Con_Data_ColName_Value]]
  volume <- env[[datatable_name]][[Con_Data_ColName_Volume]]

  #timestamp converted into integer represents seconds
  #9:30 EDT mod 86400 = 48600, 9:30 EST mod 86400 = 48600+ 3600
  #trading day is 23400s long

  #split the data into days
  #assume there is always data at 15:59

  cat('Retrieving data for', symbol, '\n')
  time_since_open <- rep(0, length(timestamp))
  num_of_minutes <- 390

  for (i in 1: length(timestamp))
    time_since_open[i] <- get_time_since_open(timestamp[i])

  N <- sum(time_since_open == 0)
  start_of_day_indices <- (1:length(timestamp))[time_since_open == 0]
  num_of_lines_per_day <- start_of_day_indices[2] - start_of_day_indices[1]

  value_by_day <- matrix(-1, nrow = N, ncol = num_of_minutes)
  volume_by_day <- matrix(-1, nrow = N, ncol = num_of_minutes)

  for (i in 1:N){
    value_by_day[i,] = value[(i - 1) * num_of_lines_per_day + (1:num_of_minutes)]
    volume_by_day[i,] = volume[(i - 1) * num_of_lines_per_day + (1:num_of_minutes)]
  }

  #time_interval = 5 #denote minutes

  Tnum = 23400 / (time_interval * 60)
  t_marker <- (time_interval * 60) * (1: Tnum)

  VWAP <- matrix(0, nrow = N, ncol = Tnum + 1)
  interval_volume = matrix(0, nrow = N, ncol = Tnum)
  VWAP[,1] = env[[datatable_name]][[Con_Data_ColName_Open]][time_since_open == 0]
  for (n in 1:N){
    interval_volume[n,] <- colSums(matrix(volume_by_day[n,], nrow = time_interval, ncol = Tnum))
    VWAP[n,2:(Tnum + 1)] <- colSums(matrix(value_by_day[n,], nrow = time_interval, ncol = Tnum)) / interval_volume[n,]
    #correct NaN prices. This is caused by the interval volume being 0. In this case VWAP is the same
    #as the last time period.
    for(t in 2:(Tnum + 1)){
      if (is.nan(VWAP[n, t])){
        VWAP[n, t] = VWAP[n, t - 1]
      }
    }
  }

  Boxcoxlambda_interval_volume <- BoxCox.lambda(interval_volume, method=c("guerrero"),lower=-5, upper=5)
  interval_volume<- BoxCox(interval_volume,lambda = Boxcoxlambda_interval_volume)

  p_increments <- VWAP[,2:(Tnum + 1)] - VWAP[,1:Tnum]
  #Boxcoxlambda_p_increments <-BoxCox.lambda(p_increments,method=c("guerrero"),lower=-5, upper=5)
  #p_increments<- BoxCox(p_increments,lambda = Boxcoxlambda_p_increments)

  p_absolute <- abs(VWAP[,2:(Tnum + 1)] - VWAP[,1:Tnum])
  Boxcoxlambda_p_absolute <-BoxCox.lambda(p_absolute,method=c("guerrero"),lower=-5, upper=5)
  p_absolute<- BoxCox(p_absolute,lambda = Boxcoxlambda_p_absolute)

  df_p_increments <- data.frame(p_increments)
  df_interval_volume <- data.frame(interval_volume)
  df_p_absolute <- data.frame(p_absolute)
  rtn_lst <- list(df_p_increments, df_interval_volume, df_p_absolute, Boxcoxlambda_interval_volume, Boxcoxlambda_p_absolute)
  names(rtn_lst) <- c('p_increments', 'interval_volume', 'p_absolute','Boxcoxlambda_interval_volume', 'Boxcoxlambda_p_absolute')
  return(rtn_lst)
}

get_params_estimates <- function (training_data, num_var, num_states)
{
  #training data is v X N X T matrix, where v is the number of state_variables, N is the number of time series, and T is the number of timesteps
  remove_pct <- 0.02

  Tnum <- dim(training_data)[3]
  N <- dim(training_data)[2]

  rows_to_remove <- rep(FALSE, N)

  for (i in 1:num_var){
    filter <- quantile(as.vector(training_data[i,,]), c(remove_pct * (1/Tnum), 1 - remove_pct * (1/Tnum)))
    rows_to_remove <- rows_to_remove | (apply(training_data[i,,], 1, max) > filter[2]) |
      (apply(training_data[i,,], 1, min) < filter[1])
  }
  data_aft_filter <- training_data[,!rows_to_remove,]
  rand_size = dim(data_aft_filter)[2]
  num_estimates <- 1

  #order of state parameters: p_increments then log volume then p_absolute
  #num_estimates is always the last dimension

  A_estimates <- array(0, c(num_states, num_states, num_estimates))
  mu_estimates <- array(0, c(num_var, num_states, num_estimates))
  cov_mat_estimates <- array(0, c(num_var, num_var, num_states, num_estimates))

  for (i in 1: num_estimates){
    tr_indices <- sample(1:dim(data_aft_filter)[2], rand_size)
    test_data = array(0, c(num_var, Tnum, rand_size))
    for (j in 1:num_var){
      test_data[j,,] <- t(data_aft_filter[j,tr_indices,])
    }
    estimate <- EM(test_data, num_states)
    A_estimates[,,i] <- data.matrix(estimate[["A"]])
    mu_estimates[,,i] <- data.matrix(estimate[["mu"]])
    cov_mat_estimates[,,,i] <- array(data.matrix(estimate[["covariance matrix"]]), c(num_var, num_var, num_states))
  }

  rtn <- list(data.frame(A_estimates), data.frame(mu_estimates),
              data.frame(cov_mat_estimates))
  names(rtn) <- c('A', 'mu', 'cov_matrix')
  return(rtn)
}

performance_test <- function(start_time, end_time, env, symbols, time_interval, num_states, num_var, A, mu, cov_mat, interval_volume_lamdas, p_absolute_lamdas){
  #if for a symbol the quotes at a particular time is not available, then
  #it is filled in by the data of the last available minute (e.g, if at 9:33 the data
  #is missing, but at 9:32 it is available, then the quote at 9:32 is taken to be the same
  # as the quote of 9:32)

  #strategy: each minute trying to predict the price movement for next minute. If predicts going
  #up then buy mkt order now and sell mkt order 1 interval later
  #if predicts going down then sell order now and buy 1 interval later
  max_day_num <- 150

  num_sym = length(symbols)
  max_exp_p_increment <- rep(0, num_sym)
  min_exp_p_increment <- rep(0, num_sym)
  for (sym in 1:num_sym){
    max_exp_p_increment[sym] <- max(A %*% mu[(sym - 1) * num_var + 1,])
    min_exp_p_increment[sym] <- min(A %*% mu[(sym - 1) * num_var + 1,])
  }

  threshold_factor <- 0.6

  current_time <- start_time
  if (sum(is.na(getquotes(env, symbols, start_time))) != 0){
    cat('Error: data not available at start time \n')
    return
  }
  else if(sum(is.na(getquotes(env, symbols, end_time))) != 0){
    cat('Error: data not available at end time \n')
    return
  }

  Tnum <- 390 / time_interval
  VWAP_prices <- matrix(NA, nrow = num_sym, ncol = Tnum + 1)
  interval_volume <- matrix(NA, nrow = num_sym, ncol = Tnum)
  cumul_volume <- rep(0, num_sym)
  cumul_value <- rep(0, num_sym)
  cumul_volatility <- rep(0, num_sym)

  orderID <- 0
  predicted_price_direction <- NA
  prediction_list <- array(NA, c(num_sym, max_day_num, Tnum))
#   p_increment_list <- matrix(NA, 0, Tnum)
#   p_absolute_list <- matrix(NA, 0, Tnum)

  current_shares_to_trade <- rep(0, num_sym)
  future_shares_to_trade <- rep(0, num_sym)
  lot_size <- 100

  eod_value <- vector()
  execution_dates <- vector()

  intraday_counter <- 1
  day_counter <- 1

  while (current_time <= end_time){

    quotes <- getquotes(env, symbols, current_time)
    if (sum(is.na(quotes)) != 0){
      current_time <- current_time + 60
      next
    }
    response <- update_pendingorderbook(env, current_time, symbols)
    if (nrow(response)!=0){
      passive_processing(response)
    }

    time_since_open <- get_time_since_open(current_time)
    cumul_value <- cumul_value + quotes[,Con_Data_ColName_LastValue]
    cumul_volume <- cumul_volume + quotes[,Con_Data_ColName_LastVolume]
    cumul_volatility <- cumul_volatility + quotes[,Con_Data_ColName_LastValue]

    if (time_since_open %% (time_interval* 60) == 0){
      current_shares_to_trade <- future_shares_to_trade
      future_shares_to_trade <- rep(0, num_sym)
      #Active processing
      if (time_since_open == 0){
        VWAP_prices <- matrix(NA, nrow = num_sym, ncol = Tnum + 1)
        VWAP_prices[,1] <- quotes[,Con_FieldName_CurrentTick]
        interval_volume <- matrix(NA, nrow = num_sym, ncol = Tnum)
        predicted_price_direction <- matrix(NA, nrow = num_sym, ncol = Tnum)
        cat('testing ', strftime(current_time, format = "%F"), '\n')
        intraday_counter = 0
      }
      else if (time_since_open == 23400){
        last_interval_VWAP_price <- cumul_value / cumul_volume
        VWAP_prices[,intraday_counter + 1] <- last_interval_VWAP_price
        p_increments <- VWAP_prices[,2:(intraday_counter + 1)] - VWAP_prices[,1:intraday_counter]
        p_absolute <- abs(VWAP_prices[,2:(intraday_counter + 1)] - VWAP_prices[,1:intraday_counter])
        prediction_list[,day_counter,] <- predicted_price_direction
#         p_increment_list <- rbind(p_increment_list, p_increments)
#         p_absolute_list <- rbind(p_absolute_list, p_absolute)
        current_time = current_time + 60 * 60 * 16
        day_counter = day_counter + 1

      }
      else{
        #price prediction for each symbol
        last_interval_VWAP_price <- matrix(0, nrow = num_sym, ncol = 1)
        for (sym in 1:num_sym){

          if (cumul_volume[sym] == 0){
            last_interval_VWAP_price[sym,] <- 0
          }
          else{
            last_interval_VWAP_price[sym,] <- cumul_value[sym] / cumul_volume[sym]
          }
        }
        last_interval_volume <- cumul_volume
        VWAP_prices[,intraday_counter + 1] <- last_interval_VWAP_price

        for (sym in 1:num_sym){
          last_interval_volume[sym] <- BoxCox(last_interval_volume[sym],lambda = interval_volume_lamdas[sym])
        }
        interval_volume[,intraday_counter] <- last_interval_volume

        p_increments <- VWAP_prices[,2:(intraday_counter + 1)] - VWAP_prices[,1:intraday_counter]
        dim(p_increments) <- c(num_sym, intraday_counter)
          #p_increments<- BoxCox(p_increments,lambda=Boxcoxlambda_p_increments)

        p_absolute <- abs(VWAP_prices[,2:(intraday_counter + 1)] - VWAP_prices[,1:intraday_counter])
        dim(p_absolute) <- c(num_sym, intraday_counter)
        test_data <- array(0, c(num_var * num_sym, intraday_counter, 1))
        for (sym in 1:num_sym){
          p_absolute[sym,]<- BoxCox(p_absolute[sym,],lambda = p_absolute_lamdas[sym])

          test_data[(num_sym - 1) * num_var + 1,,] <- p_increments[sym,]
          test_data[(num_sym - 1) * num_var + 2,,] <- interval_volume[sym,1:intraday_counter]
          test_data[(num_sym - 1) * num_var + 3,,] <- p_absolute[sym,]
        }
        log_alpha <- calc_forward(num_states, 1, intraday_counter, num_var * num_sym, A, mu, cov_mat, test_data)
        last_period_alpha <- log_alpha[,intraday_counter, 1]
        alpha <- exp(last_period_alpha - max(last_period_alpha))
        states_prob <- alpha / sum(alpha)
        next_period_prob <- t(t(states_prob) %*% A)
        next_prediction <- matrix(NA, nrow = num_sym, ncol = 1)
        for (sym in 1:num_sym){
          expected_mu <- sum(next_period_prob * mu[(num_sym - 1) * num_var + 1,]) #only calculating expected p_increments for next time period

          if (expected_mu > max_exp_p_increment[sym] * threshold_factor){
            next_prediction[sym] <- TRUE
            current_shares_to_trade[sym] <- current_shares_to_trade[sym] + lot_size
            future_shares_to_trade[sym] <- future_shares_to_trade[sym] - lot_size
          }
          else if (expected_mu < min_exp_p_increment[sym] * threshold_factor){
            next_prediction[sym] <- FALSE
            current_shares_to_trade[sym] <- current_shares_to_trade[sym] - lot_size
            future_shares_to_trade[sym] <- future_shares_to_trade[sym] + lot_size
          }
        }
        predicted_price_direction[,intraday_counter+1] <- next_prediction
      }
      new_orders = data.frame(matrix(NA, 0, length(order_msg_spec)))
      colnames(new_orders) <- order_msg_spec
      for(sym in 1:num_sym){
        if (current_shares_to_trade[sym] != 0){
          side <- (current_shares_to_trade[sym] > 0) * Con_Side_Buy + (current_shares_to_trade[sym] < 0) * Con_Side_Sell
          orders = data.frame(matrix(NA, 1, length(order_msg_spec)))
          colnames(orders) <- order_msg_spec
          orders[,Con_FieldName_MsgType] = Con_MsgType_New
          orders[,Con_FieldName_OrdID] = orderID
          orderID = orderID + 1
          orders[,Con_FieldName_Sym] = symbols[sym]
          orders[,Con_FieldName_Qty] = abs(current_shares_to_trade[sym])
          orders[,Con_FieldName_Side] = side
          orders[,Con_FieldName_OrdType] = Con_OrdType_Mkt
          new_orders <- rbind(new_orders, orders)
        }
      }
      response <- handle_orders(new_orders, symbols, env, current_time)
      if (nrow(response)!=0){
        passive_processing(response)
      }

      cumul_volume <- rep(0, num_sym)
      cumul_value <- rep(0, num_sym)
      cumul_volatility <- rep(0, num_sym)
      intraday_counter = intraday_counter + 1
    }

    if (time_since_open == 23340){
      #liquidate current position at 15:59
      positionbook <- env[[Con_GlobalVarName_PositionBook]]
      last_pos <- positionbook[[length(positionbook)]]
      if (nrow(last_pos) > 1){
        outstanding_entries <- last_pos[last_pos[,Con_FieldName_Sym] != Con_Sym_Cash,]
        clearing_order_side <- rep(0, nrow(outstanding_entries))
        for (i in 1: nrow(outstanding_entries)){
          if (outstanding_entries[i,Con_FieldName_Qty] < 0){
            clearing_order_side[i] <- Con_Side_Buy
          }
          else{
            clearing_order_side[i] <- Con_Side_Sell
          }
        }
        orders = data.frame(matrix(NA, nrow(outstanding_entries), length(order_msg_spec)))
        colnames(orders) <- order_msg_spec
        orders[,Con_FieldName_MsgType] = Con_MsgType_New
        orders[,Con_FieldName_OrdID] = orderID + 0:(nrow(outstanding_entries) - 1)
        orderID = orderID + nrow(outstanding_entries)
        orders[,Con_FieldName_Sym] = outstanding_entries[,Con_FieldName_Sym]
        orders[,Con_FieldName_Qty] = abs(outstanding_entries[,Con_FieldName_Qty])
        orders[,Con_FieldName_Side] = clearing_order_side
        orders[,Con_FieldName_OrdType] = Con_OrdType_Mkt
        response <- handle_orders(orders, symbols, env, current_time)
        if (nrow(response)!=0){
          passive_processing(response)
        }
      }
      last_pos <- env[[Con_GlobalVarName_PositionBook]][[length(env[[Con_GlobalVarName_PositionBook]])]]
      eod_value <- append(eod_value, last_pos[last_pos[,Con_FieldName_Sym] == Con_Sym_Cash, Con_FieldName_MktVal])
      execution_dates <- append(execution_dates, current_time)
      current_shares_to_trade <- rep(0, num_sym)
      future_shares_to_trade <- rep(0, num_sym)
    }

    current_time <- current_time + 60

  }
  valid_predictions <- prediction_list[,1:(day_counter-1),]
  dim(valid_predictions) <- c(num_sym, day_counter - 1, Tnum)
  predictions <- data.frame(valid_predictions)
  eod_vals <- data.frame(eod_value)
  rtn_list <- list(predictions, eod_vals)
  names(rtn_list) <- c('predictions', 'eod_values')
  return(rtn_list)

}

passive_processing <- function(response){

}


library(xtable)
source("../scripts/proc-lme.r")
source("../scripts/collate-word-feats.r")

load("xprospn.dt", verbose=T)

xs.list <- get.compare.groups(xprospn)
save(xs.list, file="x.compare.list")

x.rs.pword <- xs.list[["x.rs.pword"]]
x.rs.tstart<- xs.list[["x.rs.tstart"]]
x.rs.med <- xs.list[["x.rs.med"]]

m.start.tstart <- glmer(is.rsstart ~  (1 | spk)
		+ to.zscore(mean.normF0) + to.zscore(mean.normI0)
                + to.zscore(range.normF0) + to.zscore(range.normI0)
                + to.zscore(mean.normF0 - p.mean.normF0)
                + to.zscore(range.normF0 - p.range.normF0)
                + to.zscore(mean.normI0 - p.mean.normI0)
                + to.zscore(range.normI0 - p.range.normI0)
                + to.zscore(mean.normF0 - n.mean.normF0)
                + to.zscore(range.normF0 - n.range.normF0)
                + to.zscore(mean.normI0 - n.mean.normI0)
                + to.zscore(range.normI0 - n.range.normI0)
		, data=x.rs.tstart,  family = binomial(link = "logit"))
display(m.start.tstart)
u <- get.fixef(m.start.tstart)
u[ymin > 0]
u[ymax < 0]

m.start.med <- glmer(is.rsstart ~ (1 | spk)
		+ to.zscore(mean.normF0) + to.zscore(mean.normI0)
                + to.zscore(range.normF0) + to.zscore(range.normI0)
                + to.zscore(mean.normF0 - p.mean.normF0)
                + to.zscore(range.normF0 - p.range.normF0)
                + to.zscore(mean.normI0 - p.mean.normI0)
                + to.zscore(range.normI0 - p.range.normI0)
                + to.zscore(mean.normF0 - n.mean.normF0)
                + to.zscore(range.normF0 - n.range.normF0)
                + to.zscore(mean.normI0 - n.mean.normI0)
                + to.zscore(range.normI0 - n.range.normI0)
		, data=x.rs.med,  family = binomial(link = "logit"))
display(m.start.med)
u <- get.fixef(m.start.med)
u[ymin > 0]
u[ymax < 0]

x.re.med=xs.list[["x.re.med"]]
x.re.tend=xs.list[["x.re.tend"]]

m.end.tend <- glmer(is.rsend ~ (1 | spk)
		+ to.zscore(mean.normF0) + to.zscore(mean.normI0)
                + to.zscore(range.normF0) + to.zscore(range.normI0)
                + to.zscore(mean.normF0 - p.mean.normF0)
                + to.zscore(range.normF0 - p.range.normF0)
                + to.zscore(mean.normI0 - p.mean.normI0)
                + to.zscore(range.normI0 - p.range.normI0)
                + to.zscore(mean.normF0 - n.mean.normF0)
                + to.zscore(range.normF0 - n.range.normF0)
                + to.zscore(mean.normI0 - n.mean.normI0)
                + to.zscore(range.normI0 - n.range.normI0)
		, data=x.re.tend,  family = binomial(link = "logit"))

display(m.end.tend)
u <- get.fixef(m.end.tend)
u[ymin > 0]
u[ymax < 0]

m.end.med <- glmer(is.rsend ~  (1 | spk)
		+ to.zscore(mean.normF0) + to.zscore(mean.normI0)
                + to.zscore(range.normF0) + to.zscore(range.normI0)
                + to.zscore(mean.normF0 - p.mean.normF0)
                + to.zscore(range.normF0 - p.range.normF0)
                + to.zscore(mean.normI0 - p.mean.normI0)
                + to.zscore(range.normI0 - p.range.normI0)
                + to.zscore(mean.normF0 - n.mean.normF0)
                + to.zscore(range.normF0 - n.range.normF0)
                + to.zscore(mean.normI0 - n.mean.normI0)
                + to.zscore(range.normI0 - n.range.normI0)
		, data=x.re.med,  family = binomial(link = "logit"))
display(m.end.med)
u <- get.fixef(m.end.med)
u[ymin > 0]
u[ymax < 0]


# help functions for analysis of single cell RNAseq data from Innate lymphoid cells.
# Written by Asa K Bjorklund 2015

cv2.var.genes <- function(R,ERCC,plot=FALSE,cutP=0.1,main="CV2 vs mean",ret.coord=FALSE){
    # function adopted from code in Brenneke et al. script
    # with rpkms instead of counts

    library(statmod)
    nSamp<-ncol(ERCC)

    # calculate for ERCC
    rem<-which(rowSums(ERCC)==0)
    if (length(rem)>0) {
        ERCC<-ERCC[-rem,]
    }
    mE<-rowMeans(ERCC)
    vE<-apply(ERCC,1,var)
    cv2E<-vE/mE^2

   # for remaining genes.
   # remove all genes with sum<1
    remR<-which(rowSums(R)<1)
    R<-R[-remR,]
    mR<-rowMeans(R)
    vR<-apply(R,1,var)
    cv2R<-vR/mR^2

    # creating the fit
    mForFit<- unname( quantile( mE[ which( cv2E > .3 ) ], .95 ) )
    useForFit <- mE >= mForFit
    fit <- glmgam.fit( cbind( a0 = 1, a1tilde = 1/mE[useForFit] ), cv2E[useForFit] )
    a0 <- unname( fit$coefficients["a0"] )
    a1 <- unname( fit$coefficients["a1tilde"])

    # finding genes in R with variation over ercc
    minBiolDisp <- .5^2
    cv2th <- a0 + minBiolDisp + a0 * minBiolDisp
    psia1theta <- 1+a1
    testDenom <- ( mR * psia1theta + mR^2 * cv2th ) / ( 1 + cv2th/nSamp )

    p <- 1 - pchisq( vR * (nSamp-1) / testDenom, nSamp-1 )
    padj <- p.adjust( p, "BH" )
    sig <- padj < cutP
    sig[is.na(sig)] <- FALSE
    if (plot) {
         # Prepare the plot (scales, grid, labels, etc.)
       suppressWarnings(  plot( NULL, xaxt="n", yaxt="n",
             log="xy", xlim = range(mR), ylim = range(cv2R),
             xlab = "mean rpkm", ylab = "CV2" ))
        axis( 1, 10^(-4:5), c("0.0001", "0.001","0.01","0.1", "1", "10", "100", "1000",expression(10^4), expression(10^5) ) )
        axis( 2, 10^(-4:5), c("0.0001", "0.001","0.01","0.1", "1", "10", "100", "1000",expression(10^4), expression(10^5) ) )
        abline( h=10^(-3:4), v=10^(-5:5), col="#D0D0D0", lwd=2 )
        # Add the data points
        colS<-rep("red",nrow(R))
        colS[sig]<-"blue"
        points(mR,cv2R,pch=20,cex=0.2,col=colS)
        # add points for ERCC
        points(mE,cv2E,pch=20,cex=0.7,col="black")
        # Plot the fitted curve
        xg <- 10^seq( -2, 6, length.out=1000 )
        lines( xg, (a1)/xg + a0, col="#FF000080", lwd=3 )
        df <- nSamp - 1
        lines( xg, ( (a1)/xg + a0 ) * qchisq( .975, df ) / df,
              col="#FF000080", lwd=2, lty="dashed" )
        lines( xg, ( (a1)/xg + a0 ) * qchisq( .025, df ) / df,
              col="#FF000080", lwd=2, lty="dashed" )
        legend("topright",c("ERCC","non variable","variable"),col=c("black","red","blue"),pch=20)
        title(sprintf("%s\n%d var genes",main,length(which(sig))))
    }
    # convert the indices of sig to the original matrix before removing genes.
    idx.sig<-rep(FALSE,nrow(R)+length(remR))
    idx.sig[-remR]<-sig
    if (ret.coord) { return(list(idx.sig=idx.sig,coord=cbind(mR,cv2R))) }
    else {  return(idx.sig) }
}

change.duplicate.names<-function(names){
        # will give each gene one unique name, if some are duplicated
        t<-table(names)
        sel<-which(t>1)
        for (n in names(sel)){
            m<-which(names==n)
            for (i in 1:length(m)){
                names[m[i]] <- sprintf("%s..%d",names[m[i]],i)
            }
        }
        return(names)
}

remove.uniquenames<-function(names){
        sub("\\.\\.\\d$","",names)
}

# take a vector and create a list with indexes of all the names.
make_sets<-function(x){
   names<-names(table(x))
   l<-list()
   for (n in names){
       l[[n]]<-which(x==n)
   }
   return(l)
}

make_colors<-function(names,legend,colors){
        # make a color vector for each group based on sample names, a list of legend and colors
        col<-mat.or.vec(1,length(names))
        for (i in 1:length(legend)){
            col[names==legend[i]]<-colors[i]
            }
            return(col)
}

make.vioplot<-function(l,name="gene",text.col="black",ylim=NULL,horizontal=FALSE){
    library(vioplot)
    lm<-unlist(lapply(l,mean))
    col.idx<-round(log2(lm+1)*10)+1
    col.idx[col.idx>length(crange.log)]<-length(crange.log)
    cols<-col.log[col.idx]
    l<-lapply(l, function(x) log2(x+1))
    lz<- which(unlist(lapply(l,sum))==0)
    # if one gene is non-expressed, need to add pseudo values around zero
    for (z in lz)  { l[[z]]<-rnorm(length(l[[z]]),mean=0,sd=1e-10) }
    vioplot.list.small(l,col=cols,drawRect=F,border=NA,ylim=ylim,horizontal=horizontal)
    text(-2.5,1,name,srt=0,adj=c(0,0.2),col=text.col)
}

plot.color.bar<-function(col=col.log,crange=crange.log,main="log2(rpkm+1)"){
  barplot(rep(1,length(col)),col=col,border=NA,main=main,space=0,axes=F,cex.main=0.6)
  # round to closest 1,10,100,1000 etc.
  by.exp<-floor(log10(max(na.omit(crange))-min(na.omit(crange))))
  if (by.exp==1){
    by = 1
  }else {
    by<-10^(by.exp-1)
  }
  # if crange is not at even numbers.
  if (max(na.omit(crange)) > 100) {
    crange<-round(crange/10)*10
  }
  rem<-crange  %% by
  evens<-which(rem==0)
  if (length(evens) > 15) {
    rem<-crange  %% (by*5)
    evens<-which(rem==0)
  }
  lab<-crange[evens]
  axis(1,at=evens,labels=lab,cex.axis=0.5,las=2)
}

# also remove axes.
vioplot.list.small<- function (datas, range = 1.5, h = NULL, ylim = NULL, names = NULL,
    # modification of viplot function from cran, to take a list as input and plot smaller violins with no axes, means etc.
    horizontal = FALSE, col = "magenta", border = "black", lty = 1,
    lwd = 1, rectCol = "black", colMed = "white", pchMed = 19,
    at, add = FALSE, wex = 1, drawRect = TRUE,las=2,ylab=NULL)
{
    n <- length(datas)
    if (missing(at))
        at <- 1:n
    upper <- vector(mode = "numeric", length = n)
    lower <- vector(mode = "numeric", length = n)
    q1 <- vector(mode = "numeric", length = n)
    q3 <- vector(mode = "numeric", length = n)
    med <- vector(mode = "numeric", length = n)
    base <- vector(mode = "list", length = n)
    height <- vector(mode = "list", length = n)
    baserange <- c(Inf, -Inf)
    args <- list(display = "none")
    if (!(is.null(h)))
        args <- c(args, h = h)
    for (i in 1:n) {
        data <- datas[[i]]
        data.min <- min(data)
        data.max <- max(data)
        q1[i] <- quantile(data, 0.25)
        q3[i] <- quantile(data, 0.75)
        med[i] <- median(data)
        iqd <- q3[i] - q1[i]
        upper[i] <- min(q3[i] + range * iqd, data.max)
        lower[i] <- max(q1[i] - range * iqd, data.min)
        est.xlim <- c(min(lower[i], data.min), max(upper[i],
            data.max))
        smout <- do.call("sm.density", c(list(data, xlim = est.xlim),
            args))
        hscale <- 0.4/max(smout$estimate) * wex
       base[[i]] <- smout$eval.points
        height[[i]] <- smout$estimate * hscale
        t <- range(base[[i]])
        baserange[1] <- min(baserange[1], t[1])
        baserange[2] <- max(baserange[2], t[2])
    }
    if (!add) {
        xlim <- if (n == 1)
            at + c(-0.5, 0.5)
        else range(at) + min(diff(at))/2 * c(-1, 1)
        if (is.null(ylim)) {
            ylim <- baserange
        }
    }
    if (is.null(names)) {
        label <- 1:n
    }
    else {
        label <- names
    }
    boxwidth <- 0.05 * wex
    if (!add)
        plot.new()
    if (!horizontal) {
        if (!add) {
            plot.window(xlim = xlim, ylim = ylim)
            #axis(2)
            axis(2, labels = FALSE,tick=FALSE,col="white")
            #axis(1)
            axis(1, at = at, labels = FALSE,tick=FALSE,col="white")
        }
        box(col="white")
        if(length(col)!=n){ col<-rep(col[1],n) }
        for (i in 1:n) {
            polygon(c(at[i] - height[[i]], rev(at[i] + height[[i]])),
                c(base[[i]], rev(base[[i]])), col = col[i], border = border,
                lty = lty, lwd = lwd)
            if (drawRect) {
                lines(at[c(i, i)], c(lower[i], upper[i]), lwd = lwd,
                  lty = lty)
                rect(at[i] - boxwidth/2, q1[i], at[i] + boxwidth/2,
                  q3[i], col = rectCol)
                points(at[i], med[i], pch = pchMed, col = colMed)
            }
        }
    }
    else {
        if (!add) {
            plot.window(xlim = ylim, ylim = xlim)
            axis(1, labels = FALSE,tick=FALSE,col="white")
            axis(2, at = at, labels = FALSE,tick=FALSE,col="white")
        }
        box(col="white")
        if(length(col)!=n){ col<-rep(col[1],n) }
        for (i in 1:n) {
            polygon(c(base[[i]], rev(base[[i]])), c(at[i] - height[[i]],
                rev(at[i] + height[[i]])), col = col[i], border = border,
                lty = lty, lwd = lwd)
            if (drawRect) {
                lines(c(lower[i], upper[i]), at[c(i, i)], lwd = lwd,
                  lty = lty)
                rect(q1[i], at[i] - boxwidth/2, q3[i], at[i] +
                  boxwidth/2, col = rectCol)
                points(med[i], at[i], pch = pchMed, col = colMed)
            }
        }
    }
    invisible(list(upper = upper, lower = lower, median = med,
        q1 = q1, q3 = q3))
}

convert.to.color <- function(x,colscale,col.range=NULL){
  x.range<-range(na.omit(x))
  by=0.1
  if (is.null(col.range)){
    by=10
    col.range<-seq(x.range[1],x.range[2],by=by)
  }
  col.def<-colscale(length(col.range))
  col.idx<-round((x-x.range[1])/by)+1
  col.idx[col.idx>length(col.range)]<-length(col.range)
  cols<-col.def[col.idx]
  return(list(cols=cols,col.def=col.def,col.range=col.range))
}

##########################################
# functions for PCA plotting
run.pca<-function(data,seln=0,log.vals=TRUE,samples.col=TRUE,center=TRUE){
        if (!samples.col){ data<-t(data) }

        # remove zero read genes
        z<-which(rowSums(data)==0)
        if (length(z>0)){
            data<-data[-z,]
        }

        if (log.vals) { data <- log2(data+0.1) }

        # select top varied genes
        if (seln>0){
            sD<-apply(data,1,sd)
            o<-order(sD,decreasing=T)
            data<-data[o[1:seln],]
        }

        myPca <- prcomp(t(data),center=center,scale.=FALSE)
        vars<- myPca$sdev^2
        vars<- vars/sum(vars)
        pcnames<-mat.or.vec(1,length(vars))
        for (i in 1:length(vars)) {
            pcnames[i]<-sprintf("PC%d %.5f",i,vars[i])
        }

        myPca$pc.names<-as.vector(pcnames)
        return(myPca)
}

pca.plot <- function (data, log.vals=TRUE,seln=0,selpc=1:2,center=TRUE,samples.col=TRUE, ...){
         # data is either a prcomp object or a data matrix
         if (class(data) != "prcomp"){
            data<-run.pca(data,seln=0,log.vals=log.vals,samples.col=samples.col,center=center)
         }
         tmpPca <- as.data.frame(data$x[,selpc])
         colnames(tmpPca)<-data$pc.names[selpc]
         plot(tmpPca, ...)
         invisible(data)
}

##########################################
# functions for protein/RNA plotting

# normalize each protein and rna within the plates
# set all values below zero to zero
norm_distr <- function(x,cut=0){
    x[x<=cut]<-0
    # if none is expressed return all zeros
    if (sum(x)==0){
      return(rep(0,length(x)))
    }else {
      n = (x-min(x))/(max(x)-min(x))
      return(n)
    }
}

plot_mean<-function(data,name){
  mP<-colMeans(data[,prot.idx])
  mR<-colMeans(data[,rna.idx])

  cP<-cor(mP,mR)
  cS<-cor(mP,mR,method="spearman")

  plot(mP,mR, xlab="Mean protein abundance",ylab="Mean RNA abuncance",main=sprintf("Mean, %s, Pearson=%.4f, Spearman=%.4f",name,cP,cS))
  offset<-(max(mR)-min(mR))/30
  text(mP,mR+offset,markers,cex=0.7)
}

calculate_simstats<-function(data1,data2,ncut,nSim){
        output<-mat.or.vec(nSim,2)
        nS<-nrow(data1)
        for (s in 1:nSim) {
            set<-sample(1:nS)[1:ncut]
            output[s,1]<-cor(colMeans(data1[set,]), colMeans(data2[set,]))
            output[s,2]<-cor(colMeans(data1[set,]), colMeans(data2[set,]),method="spearman")
        }
        m<-colMeans(output)
        s<-apply(output,2,sd)
        return(c(m,s))
}

run_simulation_plot<-function(data,nSim,noPar=FALSE){
  nM<-ncol(data)/2
  c1P<-apply(data, 1, function(x) cor(x[1:nM],x[(nM+1):(nM*2)]))
  c1S<-apply(data, 1, function(x) cor(x[1:nM],x[(nM+1):(nM*2)],method="spearman"))
  stat1<-c(mean(c1P),mean(c1S),sd(c1P),sd(c1S))

  data.markers<-data[,1:nM]
  data.genes<-data[,(1+nM):(nM*2)]

  cAllP<-cor(colMeans(data.markers), colMeans(data.genes))
  cAllS<-cor(colMeans(data.markers), colMeans(data.genes),method="spearman")
  statAll<-c(cAllP, cAllS,0,0)
  nS<-nrow(data)
  by<-5
  if (nS>150) { by <- 10 }
  if (nS>300) { by <- 50 }

  subsets<-c(10,25,seq(50,nS-1 ,by=by))
  nSet<-length(subsets)

  simdata<-mat.or.vec(nSet,4) #mean/sd with P or S,
  for (i in 1:nSet) {
    simdata[i,]<-calculate_simstats(data.markers,data.genes,subsets[i],nSim)
  }

  x<-c(1,subsets,nS)
  simdata2<-rbind(stat1,simdata,statAll)

  library(gplots)

  if (!noPar) { par(mfrow=c(1,2)) }
  plotCI(x,simdata2[,1],simdata2[,3],col="black",main="Pearson",ylab="Pearson correlation",xlab="Number of cells",ylim=c(-0.1,1),xaxt="n")
  lines(x,simdata2[,1],col="black")
  axis(1,at=x,las=2,cex.axis=0.6)

  plotCI(x,simdata2[,2],simdata2[,4],col="black",main="Spearman",ylab="Spearman correlation",xlab="Number of cells",ylim=c(-0.1,1),xaxt="n")
  lines(x,simdata2[,2],col="black")
  axis(1,at=x,las=2,cex.axis=0.6)
}


#####################################################################################
# Simple CV calculation
# by: Tristan de Jong
# Last edit: 17/01/2018
#####################################################################################
library("gProfileR")
library("EDASeq")

# 0. CV calculation
getCV = function(makeCVData){
  SD1 = apply(makeCVData, 1, sd, na.rm=TRUE)
  mean1 = rowMeans(makeCVData, na.rm = TRUE)
  CV1 = SD1/mean1
  return(CV1)
}

myColors = c("red","pink","blue","lightblue")

pdf("results/analysis.pdf")

##########################################################################
#1. Read the data
##########################################################################
rawData = read.delim("data/20170306_RNASeq_Gertrud_rawcounts_0FPM.txt", header =T,
                     sep= "\t", row.names = "Gene")

phenotypes = read.delim("data/Phenotype.csv", header =T, sep = ",", row.names = "Library")
phenotypes$AgeMut = paste(phenotypes$Age,phenotypes$Mutant,sep = "_")

##########################################################################
#2. Filter to a minimum of 1 FPM and remove 0 counts
##########################################################################
Filter0 = apply(rawData,1,min) >= 1                        # All data must be non-zero
rawData = rawData[Filter0,]                                # Apply the non-zero filter

pre_fpm <- sweep(rawData,2, colSums(rawData),'/')          # Divide by all collumns
FPM_normalized <- sweep(pre_fpm, 2, 1e6, '*')            # Multiply by 1.000.000
# FPM_filter =   rowMeans(FPM_normalized[,phenotypes$AgeMut == "young_wildtype" ]) >= 1 |
#                rowMeans(FPM_normalized[,phenotypes$AgeMut == "old_wildtype"   ]) >= 1 |
#                rowMeans(FPM_normalized[,phenotypes$AgeMut == "young_knock-in" ]) >= 1 |
#                rowMeans(FPM_normalized[,phenotypes$AgeMut == "old_knock-in"   ]) >= 1
FPM_filter =  rowMeans(FPM_normalized) >= 1
filteredData = rawData[FPM_filter,]

# UQ normalize
UQ_normalized = betweenLaneNormalization(x = as.matrix(filteredData), which=c("upper"), offset=FALSE, round=FALSE)
boxplot(UQ_normalized, outline = FALSE, las = 2, cex.axis = 0.5, col = myColors[as.factor(phenotypes$AgeMut)])

##########################################################################
# 3. UQ normalized
##########################################################################
YW = UQ_normalized[,phenotypes$AgeMut == "young_wildtype"]
OW = UQ_normalized[,phenotypes$AgeMut == "old_wildtype"]
YK = UQ_normalized[,phenotypes$AgeMut == "young_knock-in"]
OK = UQ_normalized[,phenotypes$AgeMut == "old_knock-in"]

##########################################################################
#4 Get CVs
##########################################################################
YoungWT = getCV(YW)
YoungKI = getCV(YK)
OldWT = getCV(OW)
OldKI = getCV(OK)

dat = cbind(YoungWT, YoungKI,OldWT,OldKI)

dat = DataFrame(dat)

##########################################################################
# 5. CV vs CV
##########################################################################
par(mfrow=c(2,2))

myColors = c("#1B7B34","#1FB58F","#EAB126","grey","darkgrey","#F24C4E","forestgreen","lightblue","red","magenta")
myColors2 = c("#1B7B34","#1B7B3480",
              "#1FB58F","#1FB58F80",
              "#EAB126",  "#EAB12680",
              "grey", "#BEBEBE80",
              "darkgrey","#A9A9A980",
              "#F24C4E","#F24C4E80",
              "forestgreen", "#228B2280",
              "lightblue", "#0000FF80",
              "red","#FF000080",
              "magenta","#FF00FF80")
black = adjustcolor( "black", alpha.f = 0.1)

# A. Young
plot(dat$YoungWT, dat$YoungKI, main="CV YoungWT vs YoungKI",
     col=black, pch=16, cex = 0.4,
     ylim=c(0,2), xlim=c(0,2),
     xlab='CV, YoungWT', ylab='CV, YoungKI')
#abline(a=0,b=1)
abline(lm(dat$YoungKI~dat$YoungWT+0),col='red', lty=2)

top = table(dat$YoungWT>dat$YoungKI)[1]
bot = table(dat$YoungWT>dat$YoungKI)[2]
#legend(x = "topleft",    legend = top, bty = "n")
#legend(x = "bottomright",legend = bot, bty = "n")

# B. Old
plot(dat$OldWT, dat$OldKI, main="CV OldWT vs OldKI",
     col=black, pch=16, cex = 0.4,
     ylim=c(0,2), xlim=c(0,2),
      xlab='CV, OldWT', ylab='CV, OldKI')
#abline(a=0,b=1)
abline(lm(dat$OldKI~dat$OldWT+0),col='red', lty=2)

top = table(dat$OldWT>dat$OldKI)[1]
bot = table(dat$OldWT>dat$OldKI)[2]
#legend(x = "topleft",    legend = top, bty = "n")
#legend(x = "bottomright",legend = bot, bty = "n")

# C. WT
plot(dat$YoungWT, dat$OldWT, main="CV YoungWT vs OldWT",
     col=black, pch=16, cex = 0.4,
     ylim=c(0,2), xlim=c(0,2),
     xlab='CV, YoungWT', ylab='CV, OldWT')
#abline(a=0,b=1)
abline(lm(dat$OldWT~dat$YoungWT+0),col='red', lty=2)

top = table(dat$YoungWT>dat$OldWT)[1]
bot = table(dat$YoungWT>dat$OldWT)[2]
#legend(x = "topleft",    legend = top, bty = "n")
#legend(x = "bottomright",legend = bot, bty = "n")

# D. KI
plot(dat$YoungKI, dat$OldKI, main="CV YoungKI vs OldKI",
     col=black, pch=16, cex = 0.4,
     ylim=c(0,2), xlim=c(0,2),
     xlab='CV, YoungKI', ylab='CV, OldKI')
#abline(a=0,b=1)
abline(lm(dat$OldKI~dat$YoungKI+0),col='red', lty=2)

top = table(dat$YoungKI>dat$OldKI)[1]
bot = table(dat$YoungKI>dat$OldKI)[2]
#legend(x = "topleft",    legend = top, bty = "n")
#legend(x = "bottomright",legend = bot, bty = "n")

##########################################################################
#6. Boxplots
##########################################################################
par(mfrow=c(1,1))

boxplot(dat$YoungWT,dat$YoungKI,dat$OldWT, dat$OldKI,col = myColors,
        main = "Boxplot of BCV's",
        names = c("Young WT","Young KI","Old WT","Old KI"), las = 2)

##########################################################################
#7. Find DE
##########################################################################

## Effect of age on young
YoungWT_YoungKI = rownames(dat[dat$YoungWT  > dat$YoungKI *2,]) # Increase in noise
YoungKI_YoungWT = rownames(dat[dat$YoungWT  < dat$YoungKI /2,]) # Decrease in noise
Young_even      = rownames(dat[dat$YoungWT  < dat$YoungKI *2 & dat$YoungWT  > dat$YoungKI /2,]) # No change

# Effect of Knock in on old
OldWT_OldKI = rownames(dat[dat$OldWT  > dat$OldKI *2,]) # Increase in noise
write.csv(OldWT_OldKI,"OldWT_OldKI.csv")

OldKI_OldWT = rownames(dat[dat$OldWT  < dat$OldKI /2,]) # Decrease in noise
write.csv(OldKI_OldWT,"OldKI_OldWT.csv")

Old_even    = rownames(dat[dat$OldWT  < dat$OldKI *2 & dat$OldWT  > dat$OldKI /2,]) # No change

# Effect of age on noise
YoungWT_OldWT = rownames(dat[dat$YoungWT > dat$OldWT *2,]) # Increase in noise
OldWT_YoungWT = rownames(dat[dat$YoungWT < dat$OldWT /2,]) # Decrease in noise
WT_even       = rownames(dat[dat$YoungWT < dat$OldWT *2 & dat$YoungWT > dat$OldWT /2,]) # No change

# Effect of age on KI
YoungKI_OldKI = rownames(dat[dat$YoungKI > dat$OldKI *2,]) # Increase in noise
OldKI_YoungKI = rownames(dat[dat$YoungKI < dat$OldKI /2,]) # Decrease in noise
KI_even       = rownames(dat[dat$YoungKI < dat$OldKI *2 & dat$YoungKI > dat$OldKI /2,]) # No change

dev.off()

##########################################################################
#8. GO-terms
##########################################################################
pdf("results/GO_Terms.pdf")
par(mar=c(5.1,18.1,4.1,2.1), xpd = TRUE,mfrow=c(1,1)) #  bottom, left, top and right

######################################################################################################################################################
# # # Gprofile background
# background = rownames(dat)
# localGprofile   =   gprofiler(background, organism = "mmusculus", ordered_query = F,
#                               significant = F, exclude_iea = F, underrep = F, evcodes = F,
#                               region_query = F, max_p_value = 1, min_set_size = 0, max_set_size = 0,
#                               min_isect_size = 0, correction_method = "analytical",
#                               hier_filtering = "none", domain_size = "annotated", custom_bg = "",
#                               numeric_ns = "", png_fn = NULL, include_graph = F, src_filter = c("GO:BP", "GO:MF", "GO:CC"))
#
# # src_filter = c("GO:BP", "GO:MF", "GO:CC")
# # src_filter = NULL
# #localGprofile = localGprofile[,1:13]
# write.table(localGprofile, file =  "data/GObackground2.csv", sep = "\t", row.names = FALSE)
######################################################################################################################################################

query = YoungWT_OldWT

goProfileThis = function(query, outname){
    localGprofile   =   gprofiler(query, organism = "mmusculus", ordered_query = F,
                                  significant = T, exclude_iea = F, underrep = F, evcodes = F,
                                  region_query = F, max_p_value = 1, min_set_size = 0, max_set_size = 0,
                                  min_isect_size = 0, correction_method = "analytical",
                                  hier_filtering = "none", #("none","moderate")
                                  domain_size = "annotated", custom_bg = "",
                                  numeric_ns = "", png_fn = NULL, include_graph = F, src_filter = c("GO:BP", "GO:MF", "GO:CC"))     # src_filter = c("GO:BP", "GO:MF", "GO:CC")
    #(GO:BP, GO:MF, GO:CC to select a particular GO branch), KEGG, REAC, TF, MI, CORUM, HP, HPA, OMIM.
    # src_filter = NULL
    localGprofile = localGprofile[,1:13]
    rownames(localGprofile) =  localGprofile$term.name

    outFolder = "results/gprofiled/"
    outFile = paste(outname,".csv",sep = "")
    write.csv(localGprofile, file =  paste(outFolder,outFile, sep = ""), row.names = FALSE)
    return(localGprofile)
    }

plotGO = function(inSet, plotLabel){
    cutoff = 0.8
    a = reference[rownames(inSet),6]/reference[rownames(inSet),5] # GO terms for the reference
    b = inSet[,6]/inSet[,5]                                       # GO terms for my querie

    b/a
    Interest = rownames(inSet[which(b/a > cutoff),])
    localCol = ifelse (b/a > cutoff, "red","black")
    range = c(min(c(a,b)), max(c(a,b)))

    if (length(Interest) >0){
      print(paste( plotLabel,length(Interest)))
      myBar = barplot(( inSet[Interest,6]/inSet[Interest,5]) /
                        (reference[Interest,6]/reference[Interest,5]), las = 2 ,
                      horiz = TRUE,
                      col = c("grey",myColors))
      axis(2, at=myBar[,1],
           labels=inSet[Interest,12],
           las = 2,
           cex.axis = ifelse(length(Interest)>10,0.4,0.8))

      text(inSet[Interest,6], y = myBar[,1], x = 0.4, cex = 0.5)

      title(main = paste(plotLabel,"\n","overrepresented"),
            cex.main = 0.75)
    }
    abline(v = 1, lty = 2)
    abline(v = 1.5, lty = 2)
    return(Interest)
}

# Load the background
reference = read.csv("data/GObackground.csv", sep = ",")
rownames(reference) = reference$term.name

# 1. Consequences of ageing without mutation.
GO  = goProfileThis(YoungWT_OldWT, "YoungWT_OldWT")
plotGO(GO, "YoungWT_OldWT")

GO  = goProfileThis(OldWT_YoungWT, "OldWT_YoungWT")
plotGO(GO, "YoungWT_OldWT")

# 2. Consequences of ageing with mutation
GO  = goProfileThis(YoungKI_OldKI , "YoungKI_OldKI")
plotGO(GO, "YoungKI_OldKI")

GO  = goProfileThis(OldKI_YoungKI, "OldKI_YoungKI")
plotGO(GO, "OldKI_YoungKI")

# 3. Consequences of ageing regardless of Mutation
twoGo = intersect(YoungWT_OldWT,YoungKI_OldKI)
GO  = goProfileThis(twoGo, "Both Young _ Both Old")
plotGO(GO, "Both Young _ Both Old")

twoGo = intersect(OldWT_YoungWT,OldKI_YoungKI)
GO  = goProfileThis(twoGo, "Both Old _ Both Young")
plotGO(GO, "Both Old _ Both Young")

# 4. Consequences mutation on Young
GO  = goProfileThis(YoungWT_YoungKI , "YoungWT_YoungKI")
plotGO(GO, "YoungWT_YoungKI")

GO  = goProfileThis(YoungKI_YoungWT , "YoungKI_YoungWT")
plotGO(GO, "YoungKI_YoungWT")

# 5. Consequences mutation on Old
GO  = goProfileThis(OldWT_OldKI, "OldWT_OldKI")
plotGO(GO, "OldWT_OldKI")

GO  = goProfileThis(OldKI_OldWT, "OldKI_OldWT")
plotGO(GO, "OldKI_OldWT")

# 6. The effect of KI regardless of age
twoGo = intersect(OldWT_OldKI,YoungWT_YoungKI)
GO  = goProfileThis(twoGo, "Both WT _ Both KI")
plotGO(GO,  "Both WT _ Both KI")

twoGo = intersect(OldKI_OldWT,YoungKI_YoungWT)
GO  = goProfileThis(twoGo, "Both KI _ Both WT")
plotGO(GO,  "Both KI _ Both WT")

dev.off()


%r

library(SparkR)

df <- sql("SELECT * FROM `v_7d`")

xt <- xtabs(~prior_type+current_type, data=collect(df))

print(xt)

chisq.test(xt)


## 1. Visualizing Data for Multiple Populations ##

life_expec <- read_csv("life_expec.csv")

## 3. Graphing Life Expectancies for Men and Women: Multiple Panels ##

ggplot(data = life_expec_sex,
  aes(x = Year, y = Avg_Life_Expec)) +
  facet_wrap(~ Sex, ncol = 1) +
  geom_line()

## 4. Graphing Life Expectancies for Men and Women on the Same Axes ##

ggplot(data = life_expec_sex,
  aes(x = Year, y = Avg_Life_Expec, color = Sex)) +
  geom_line()

## 5. Graphing a Subset of Data ##

# ggplot(data = life_expec_sex,
#   aes(x = Year, y = Avg_Life_Expec, color = Sex)) +
#   geom_line()
ggplot(data = life_expec_sex,
  aes(x = Year, y = Avg_Life_Expec, color = Sex)) +
  geom_line() +
  xlim(1900, 1950)

## 6. Exploring the Data Further ##

life_expec_sex_race <- life_expec %>%
  filter((Sex == "Female" | Sex == "Male") & (Race == "Black" | Race == "White"))

## 7. Manipulating Multiple Line Graph Aesthetics ##

ggplot(data = life_expec_sex_race,
  aes(x = Year, y = Avg_Life_Expec, color = Sex, lty = Race)) +
  geom_line() +
  scale_color_manual(values = c("darkgreen", "darkorchid")) +
  scale_linetype_manual(values = c(1,4))

## 8. Deciding How to Present the Data ##

ggplot(data = life_expec_sex_race,
  aes(x = Year, y = Avg_Life_Expec, lty = Race)) +
  geom_line() +
  scale_linetype_manual(values = c(1,4)) +
  facet_wrap(~Sex, ncol = 2) +
  labs(title = "United States Life Expectancy: 100 Years of Change", y = "Average Life Expectancy (Years)") +
  theme(panel.background = element_rect(fill = "white"))

Data Analyst in R/Step 2 - Data Visualization in R/Data Visualization in R/2. Creating Multiple Line Graphs.r


#- windrose.- Wind rose from a data frame with columns: DateTime, Dir, Speed.
# Version 1.0 (2020-08-08), by Jose A. Guijarro. (GPL license >= 2.0).
#---------------------------------------------------------------------------
# data: Data frame with columns 'DateTime, Dir, Speed'
# code: Station code
# name: Station name
# uni='m/s': Wind speed units (for the legend).
# maxnsc=8 : Maximum number of wind speed classes.
# fnum=4 : Number of reference circles to plot.
# fint=5 : Frequency intervals (in %) of the reference circles.
# flab=2 : Which circles must be labelled. 1=outer circle only; 2=all.
# col=rainbow(10,.5,.92,start=.33,end=.2) : Colors to fill the polygons.
# ang=3*pi/16 : Angle along which circles will be labelled.
# margin=c(0, 0, 4, 0) : Margins vector for the plot.
#---------------------------------------------------------------
windrose <- function(data, code='', name='', uni='m/s', maxnsc=8, fnum=4,
  fint=5, flab=2, col=rainbow(10,.5,.92,start=.33,end=.2), ang=3*pi/16,
  margin=c(0,0,4,0)) {

  #----------- compute frequencies by directions ---------------
  z <- range(data[,1]) #round date/time to just date:
  startdate <- as.Date(z[1]); enddate <- as.Date(z[2])
  dd <- data[,2]; vv <- data[,3]; rm(data)
  dd[dd<0 | dd>360] <- NA #avoid bad or variable direction values
  vv[is.na(dd)] <- NA #avoid speeds with missing direction
  nd <- sum(!is.na(vv)) #nr. of available data
  if(nd==0) stop('No data available for that station and dates\n')
  cal <- sum(vv==0,na.rm=TRUE) #nr. of calm wind observations
  dd <- round(dd/360*16+1); dd[dd==17] <- 1 #direction classes
  vm <- tapply(vv,as.factor(dd),mean,na.rm=TRUE) #mean speed by direction
  vx <- tapply(vv,as.factor(dd),max,na.rm=TRUE) #max. speed by direction
  vmt <- mean(vv,na.rm=TRUE) #overall mean speed
  vmx <- max(vv,na.rm=TRUE) #overall max. speed
  vv[vv==0] <- NA #remove calm observations
  dd[is.na(vv)] <- NA #avoid directions with missing speed
  vvc <- pretty(vv) #speed classes
  nvvc <- length(vvc)-1 #number of speed classes
  #convert wind speeds to factor classes:
  if(nvvc>maxnsc) { #if too many speed classes, limit their number:
    nvvc <- maxnsc
    vvf <- cut(vv,c(vvc[1:maxnsc],999))
    spclasses <- paste(vvc[1:nvvc],vvc[2:(nvvc+1)],sep='-')
    if(latex) spclasses[nvvc] <- paste('>=',vvc[maxnsc])
    else spclasses[nvvc] <- paste('>=',vvc[maxnsc])
    geflag <- TRUE
  } else {
    vvf <- cut(vv,vvc)
    spclasses <- paste(vvc[1:nvvc],vvc[2:(nvvc+1)],sep='-')
    geflag <- FALSE
  }
  #compute the frequency table:
  fr <- table(vvf,dd)
  #if there are void direction classes, fill them with zeroes:
  z <- as.integer(colnames(fr))
  if(length(z)<16) {
    zrn <- rownames(fr)
    zm <- matrix(rep(0,16*nrow(fr)),dim(fr))
    zm[,z] <- fr
    fr <- zm
    colnames(fr) <- as.character(1:16)
    rownames(fr) <- zrn
  }
  #distribute calms in the first speed class:
  nd1 <- sum(fr[1,]); fr[1,] <- fr[1,] * (nd1+cal)/nd1
  if(nd>0) fr <- fr*100./nd #compute frequencies as percentages
  frt <- apply(fr,1,sum) #sum frequencies by speed classes
  frtd <- apply(fr,2,sum) #sum frequencies by direction classes
  #----------- build the table of frequencies ------------------
  tab <- cbind(fr,frt)
  tab <- round(rbind(tab,c(frtd,sum(frtd))),1)
  tab <- data.frame(rbind(tab,round(c(vm,vmt),1),round(c(vx,vmx),1)))
  names(tab) <- c('N','NNE','NE','ENE','E','ESE','SE','SSE','S','SSW','SW',
    'WSW','W','WNW','NW','NNW','Total')
  row.names(tab) <- c(spclasses,'Total','Mean Sp.','Mx.M.Sp.')
  #----------- plot the windrose -------------------------------
  old.par <- par(no.readonly = TRUE)
  on.exit(par(old.par))
  fr <- tab[1:nvvc,1:16]
  if(geflag) row.names(fr)[nvvc] <- paste('>=',vvc[nvvc])
  ndir <- 16 #nr. of direction classes
  nr <- nvvc #nr. of speed classes
  fmax <- fnum*fint #max. frequency to be circled
  key <- (nr>1) #legend if more than one speed class
  #make room for the legend at the left side:
  if(key) mlf <- 3 else mlf <- 1  #left margin factor
  par(mar=margin, new=FALSE)    #windrose margin
  # x,y components for every wind direction and plot settings:
  fx <- cos(pi/2-(2*pi/ndir*0:(ndir-1)))
  fy <- sin(pi/2-(2*pi/ndir*0:(ndir-1)))
  plot(fx,fy,xlim=c(-fmax-mlf*fint,fmax+fint),ylim=c(-fmax-fint,fmax+fint),
    xaxt="n",yaxt="n",xlab="",ylab="",bty="n",asp=1,type="n")
  if(nr==1) {  #only one speed class
    cx <- fx*fr
    cy <- fy*fr
  }
  else {  #more than one speed classes
    f <- apply(fr,2,sum)
    cx <- fx*f
    cy <- fy*f
    for(i in nr:2) {
      f <- f-fr[i,]
      cx <- c(cx,NA,fx*f)
      cy <- c(cy,NA,fy*f)
    }
  }
  polygon(cx,cy,col=col[nr:1])
  symbols(c(0*1:fnum),c(0*1:fnum),circles=c(fint*1:fnum),inches=FALSE,add=TRUE)
  segments(0*1:ndir,0*1:ndir,fmax*fx,fmax*fy)
  fmaxi <- fmax+fint/4
  text(0,fmaxi,"N")
  text(0,-fmaxi,"S")
  text(fmaxi,0,"E")
  text(-fmaxi,0,"W")
  if(flab==2)
    for(i in 1:fnum) text(i*fint*cos(ang),i*fint*sin(ang),paste(i*fint,"%"))
  else if(flab==1)
    text(fmax*cos(ang),fmax*sin(ang),paste(fmax,"%"))
  if(key) { #legend
    legend(-fmaxi-2.3*fint,fmaxi+2,fill=col,legend=spclasses)
    text(-fmaxi-1.5*fint,fmaxi+.9*fint,uni)
  }
  title(paste(name,'windrose\n',startdate,'to',enddate))
  invisible(tab)
}


# Required packages
# Importing the neccesary library
library(readr)
library(knitr)
library(kableExtra)
library(dplyr)
library(tidyr)
library(ggplot2)
library(MVN)
library(outliers)
library(forecast)

# read the data

happiness <- read.csv("2019.csv",
                      stringsAsFactors = FALSE)

Continents <- read.csv("Countries-Continents.csv",
                       stringsAsFactors = FALSE)

#Displaying head of two datasets
head(happiness)

head(Continents)

#Merging Two Datasets
df <- happiness %>% left_join(Continents, c("Country.or.region" = "Country"))

head(df)

# Understand
# structure of data
str(df)

df$Continent <- factor(df$Continent,
                       levels = c("Africa","Asia","Europe","North America","Oceania","South America"),
                       labels = c("Africa","Asia","Europe","North America","Oceania","South America"),
                       ordered = FALSE)
levels(df$Continent)

str(df)

# Tidy & Manipulate Data I
df <- df %>% pivot_longer(names_to = "Criteria", values_to = "Criteria_score", cols = 4:9)

df$Criteria <- as.factor(df$Criteria)
levels(df$Criteria)
str(df)

head(df)

# Tidy & Manipulate Data II
df <- df %>% group_by(Country.or.region) %>% mutate(Dystopia_Residual = Score - sum(Criteria_score))
df

# Scan I
# missing value
sum(is.na(df))

colSums(is.na(df))

df[!complete.cases(df),] %>% select(Country.or.region, Continent) %>% unique()

# handling missing values
df$Continent[df$Country.or.region=="United States"] <- "North America"
df$Continent[df$Country.or.region=="Czech Republic"] <- "Europe"
df$Continent[df$Country.or.region=="Taiwan"] <- "Asia"
df$Continent[df$Country.or.region=="Trinidad & Tobago"] <- "South America"
df$Continent[df$Country.or.region=="Kosovo"] <- "Europe"
df$Continent[df$Country.or.region=="South Korea"] <- "Asia"
df$Continent[df$Country.or.region=="Northern Cyprus"] <- "Europe"
df$Continent[df$Country.or.region=="Russia"] <- "Europe"
df$Continent[df$Country.or.region=="Hong Kong"] <- "Asia"
df$Continent[df$Country.or.region=="North Macedonia"] <- "Europe"
df$Continent[df$Country.or.region=="Congo (Brazzaville)"] <- "Africa"
df$Continent[df$Country.or.region=="Palestinian Territories"] <- "Asia"
df$Continent[df$Country.or.region=="Burkina Faso"] <- "Africa"
df$Continent[df$Country.or.region=="Congo (Kinshasa)"] <- "Africa"
df$Continent[df$Country.or.region=="Myanmar"] <- "Asia"

NA_counts <- function(x)
{
  if (is.numeric(x)) (is.infinite(x) | is.nan(x) | is.na(x))
}
sapply(df, function(x) sum(NA_counts(x)))

# Scan II
par(mar=c(1,1,1,1))

numeric <- df[, c(3,7)] %>% unique()
numeric

#Score
par(mfrow = c(1,2))

hist(numeric$Score,
     ylab = "frequency",
     xlab = "Happiness Score",
     main = "Histogram of Happiness Score")

qqnorm(numeric$Score)
qqline(numeric$Score,
       col="red",
       lwd = 1,
       lty = 2)

par(mfrow = c(1,1))

# shapiro-wilk test
shapiro.test(numeric$Score)

z.Score <- numeric$Score %>%  scores(type = "z")
z.Score %>% summary()

which(abs(z.Score) >3 )

# boxplots
ggplot(data = df, mapping = aes(y = Score)) +
  geom_boxplot() +
  ggtitle("Boxplot of Happiness Score")

par(mfrow = c(1,2))
hist(numeric$Dystopia_Residual,
     ylab = "frequency",
     xlab = "Dystopia_Residual",
     main = "Histogram of Dystopia_Residual")

# qq-plot
qqnorm(numeric$Dystopia_Residual)
qqline(numeric$Dystopia_Residual,
       col="red",
       lwd = 1,
       lty = 2)

par(mfrow = c(1,1))

shapiro.test(numeric$Dystopia_Residual)

z.Score <- df$Score %>%  scores(type = "z")
z.Score %>% summary()

# standardised Residuals
which(abs(z.Score) >3 )

ggplot(data = df, mapping = aes(y = Dystopia_Residual)) +
  geom_boxplot()

#Criteria_score

ggplot(data = df, mapping = aes(x = Criteria, y = Criteria_score)) +
  geom_boxplot()

#Two-Variable
# Scatterplot
ggplot(data = numeric) +
  geom_point(mapping = aes(x = Score, y = Dystopia_Residual)) +
  geom_smooth(
    mapping = aes(x = Score, y = Dystopia_Residual)
  )

#Multivariate

par(mar=c(1,1,1,1))

# mvn
results <- mvn(data = numeric,
               multivariateOutlierMethod = "quan",
               showOutliers = TRUE)

# Transform
#Dystopia_Residual
par(mfrow = c(3,2))

boxcox <- BoxCox(numeric$Dystopia_Residual,lambda = "auto") %>% round(3)
hist(boxcox)

log_dystopia <- log10(numeric$Dystopia_Residual)
hist(log_dystopia)

z_df <- scale(numeric$Dystopia_Residual, center = TRUE, scale = TRUE)
hist(z_df)

ln_dystopia <- log(numeric$Dystopia_Residual)
hist(ln_dystopia)

sqrt_dystopia <- sqrt(numeric$Dystopia_Residual)
hist(sqrt_dystopia)

center_df <-scale(numeric$Dystopia_Residual, center = TRUE, scale = FALSE)
hist(center_df)

par(mfrow = c(1,1))

shapiro.test(boxcox)
shapiro.test(log_dystopia)
shapiro.test(z_df)
shapiro.test(ln_dystopia)
shapiro.test(sqrt_dystopia)
shapiro.test(center_df)

#Histogram of Each Criteria

par(mfrow = c(3,2))
df_GDP <- df %>% filter(Criteria=="GDP.per.capita")
hist(df_GDP$Criteria_score)

df_social <- df %>% filter(Criteria=="Social.support")
hist(df_social$Criteria_score)

df_healthy <- df %>% filter(Criteria=="Healthy.life.expectancy")
hist(df_healthy$Criteria_score)

df_freedom <- df %>% filter(Criteria=="Freedom.to.make.life.choices")
hist(df_freedom$Criteria_score)

df_geno <- df %>% filter(Criteria=="Generosity")
hist(df_geno$Criteria_score)

df_corrupt <- df %>% filter(Criteria=="Perceptions.of.corruption")
hist(df_corrupt$Criteria_score)

par(mfrow = c(1,1))

# decreasing the skewness
z_df <- scale(df_geno$Criteria_score, center = TRUE, scale = TRUE)
hist(z_df)

sqrt_dystopia <- sqrt(df_geno$Criteria_score)
hist(sqrt_dystopia)

center_df <-scale(df_geno$Criteria_score, center = TRUE, scale = FALSE)
hist(center_df)

par(mfrow = c(1,1))

shapiro.test(z_df)
shapiro.test(sqrt_dystopia)
shapiro.test(center_df)


##Shape=vector point
##Rinde=field Shape
##output_plots_to_html
##Distancia=number 35
##showplots
##inliers=output vector

#02/07/2020
#SE RETOMO LA FUNCION moran.plot ORIGINAL DESDE GITHUB, el 6/05/2020 el autor hizo
#cambios y dejo de funcionar las funciones como estaban programadas
moran.plot2 <- function(x, listw, zero.policy=NULL, spChk=NULL,
                       labels=NULL, xlab=NULL, ylab=NULL, quiet=NULL, ...)
{
  if (!inherits(listw, "listw")) stop(paste(deparse(substitute(listw)),
                                            "is not a listw object"))
  if (is.null(quiet)) quiet <- !get("verbose", envir = .spdepOptions)
  stopifnot(is.vector(x))
  stopifnot(is.logical(quiet))
  if (is.null(zero.policy))
    zero.policy <- get("zeroPolicy", envir = .spdepOptions)
  stopifnot(is.logical(zero.policy))
  xname <- deparse(substitute(x))
  if (!is.numeric(x)) stop(paste(xname, "is not a numeric vector"))
  if (any(is.na(x))) stop("NA in X")
  n <- length(listw$neighbours)
  if (n != length(x)) stop("objects of different length")
  if (is.null(spChk)) spChk <- get.spChkOption()
  if (spChk && !chkIDs(x, listw))
    stop("Check of data and weights ID integrity failed")
  labs <- TRUE
  if (is.logical(labels) && !labels) labs <- FALSE
  if (is.null(labels) || length(labels) != n)
    labels <- as.character(attr(listw, "region.id"))
  wx <- lag.listw(listw, x, zero.policy=zero.policy)
  if (is.null(xlab)) xlab <- xname
  if (is.null(ylab)) ylab <- paste("spatially lagged", xname)
  plot(x, wx, xlab=xlab, ylab=ylab, ...)
  if (zero.policy) {
    n0 <- wx == 0.0
    # bug found 100401 Paulo Grahl
    if (any(n0)) {
      symbols(x[n0], wx[n0], inches=FALSE,
              circles=rep(diff(range(x))/50, length(which(n0))),
              bg="grey", add=TRUE)
    }
  }
  xwx.lm <- lm(wx ~ x)
  abline(xwx.lm)
  abline(h=mean(wx), lty=2)
  abline(v=mean(x), lty=2)
  infl.xwx <- influence.measures(xwx.lm)
  is.inf <- which(apply(infl.xwx$is.inf, 1, any))
  points(x[is.inf], wx[is.inf], pch=9, cex=1.2)
  if (labs)
    text(x[is.inf], wx[is.inf], labels=labels[is.inf], pos=2, cex=0.7)
  rownames(infl.xwx$infmat) <- labels
  if (!quiet) summary(infl.xwx)
  invisible(infl.xwx)
}

library(sp)
library(spdep)

crs_imagen<-st_crs(Shape)
filtro1 <- as_Spatial(Shape)

cord <- filtro1@coords
gri <- dnearneigh(cord,0,Distancia)
lw <- nb2listw(gri, style = "W",zero.policy=TRUE)
par(mfrow=c(1,1))

ML <- localmoran (filtro1@data[,Rinde], lw, p.adjust.method="bonferroni",alternative ="less",zero.policy=TRUE)
MP <- moran.plot2(filtro1@data[,Rinde],lw,quiet=T,labels=F,col=3,zero.policy=T,xlab="Rendimiento", ylab="Rendimiento Spatially Lagged")
Influ <- MP$is.inf
datos0 <- data.frame(filtro1@data,filtro1@coords,ML,Influ)

#eliminacion de datos con ?ndice de Moran Local negativo y estad?sticamente significativos (p<0.05).
datos1 <- subset(datos0,datos0$Ii > 0 | datos0$Pr.z...0.>0.05)
myshp.inlier<- subset(datos0,datos0$Ii < 0 | datos0$Pr.z...0.<0.05)

datos2 <- datos1[datos1$dfb.1_ == FALSE & datos1$dfb.x == FALSE
                   & datos1$dffit == FALSE & datos1$cov.r == FALSE & datos1$cook.d
                   == FALSE & datos1$hat == FALSE, ]

>print("--------------------------------------------------------")
>str(datos2)

datos3<-data.frame(datos2[Rinde],datos2["coords.x1"],datos2["coords.x2"])
coordinates(datos2)<-c("coords.x1","coords.x2")
output <-sf::st_as_sf(datos3, coords = c("coords.x1", "coords.x2"),crs= crs_imagen)

n<-nrow(filtro1@data[Rinde])-nrow(datos3[Rinde])
>print(paste("Se filtraron",n,"puntos"))

inliers = output


#edges should be a data frame with
#from
#to,
#ID
#capacity
#cost

network_lp_constraints <- function(net, total_flow, k_inf_cap)
{

  f_capped_edges = net$capacity < k_inf_cap
  n_cap = sum(f_capped_edges)
  lhs_cap_constr = data.frame(id=1:n_cap,
									edge= net$ID[f_capped_edges],
									coef=rep(1, n_cap))

  rhs_cap_constr = net$capacity[f_capped_edges]
  dir_cap_constr = rep('<=', times = n_cap)

  next_cnstr_id = nrow(lhs_cap_constr) + 1

  f_min_capped_edges = net$min_capacity > 0
  n_min_cap = sum(f_min_capped_edges)
  if(n_min_cap > 0) {
		lhs_min_cap_constr = data.frame(id = next_cnstr_id:(next_cnstr_id + n_min_cap - 1),
                                  edge = net$ID[f_min_capped_edges],
                                  coef = rep(1,n_min_cap))

		rhs_min_cap_constr = net$min_capacity[f_min_capped_edges]
		dir_min_cap_constr = rep('>=', times = n_min_cap)

		next_cnstr_id = next_cnstr_id + nrow(lhs_min_cap_constr)
		lhs_cap_constr = rbind(lhs_cap_constr, lhs_min_cap_constr)
		rhs_cap_constr = c(rhs_cap_constr, rhs_min_cap_constr)
		dir_cap_constr = c(dir_cap_constr, dir_min_cap_constr)
  }

#no source constraint
  f = net$from != 1
  lhs_flow_constr_o = data.frame(id = (next_cnstr_id - 2 + net$from[f]),
									edge = net$ID[f],
									coef = rep(-1,sum(f)))

#no sink consraint
  f = net$to != max(net$to)
  lhs_flow_constr_i = data.frame(id =next_cnstr_id -2 + net$to[f],
									edge = net$ID[f],
									coef=rep(1, sum(f)))
  rhs_flow_constr = rep(0, max(net$to)- 2)
  dir_flow_constr = rep('==', max(net$to) - 2)

  next_cnstr_id = next_cnstr_id + max(net$to) - 2

  src_adj = net[net$from == 1,"ID"]
  sink_adj = net[net$to == max(net$to),"ID"]
  lhs_src_constr = data.frame(id = rep(next_cnstr_id, length(src_adj)),
									edge = src_adj,
									coef=rep(1, length(src_adj)))
  rhs_src_constr = total_flow
  dir_src_constr = '=='

  next_cnstr_id = next_cnstr_id + 1
  lhs_sink_constr = data.frame(id = rep(next_cnstr_id, length(sink_adj)),
									edge = sink_adj,
									coef=rep(1, length(sink_adj)))
  rhs_sink_constr = total_flow
  dir_sink_constr = '=='

  # Build constraints matrix
  lhs_df = rbind(rbind(lhs_cap_constr, lhs_flow_constr_o), lhs_flow_constr_i)
  lhs_df = rbind(rbind(lhs_df, lhs_src_constr), lhs_sink_constr)
#  lhs = sparseMatrix(i = lhs_df$id, lhs_df$edge, x= lhs_df$coef)
  lhs = slam::simple_triplet_matrix(i = lhs_df$id, lhs_df$edge, v= lhs_df$coef)
  constraints <- list(
    lhs = lhs,
    dir = c(dir_cap_constr, dir_flow_constr, dir_src_constr, dir_sink_constr),
    rhs = c(rhs_cap_constr, rhs_flow_constr, rhs_src_constr, rhs_sink_constr))
	return(constraints)
}

gen_lp_from_net = function(net, ncnstr)
{
#	lpfl = make.lp(nrow=nrow(ncnstr$lhs), ncol=ncol(ncnstr$lhs))
	lpfl = make.lp(nrow=nrow(ncnstr$lhs))
	for(i in seq(1,ncol(ncnstr$lhs),10000)) {
		to_i = min(i + 10000 - 1, ncol(ncnstr$lhs))
		message("add ", i, " - ", to_i, " cnstr")
		apply(ncnstr$lhs[,i:to_i], 2, function(x) add.column(lpfl, x))
	}
	set.objfn(lpfl, net$net$cost)
	set.constr.type(lpfl, ncnstr$dir)
	set.rhs(lpfl, ncnstr$rhs)

#	for(i in 1:nrow(ncnstr$lhs)) {
#			add.constraint(lpfl, ncnstr$lhs[i,], ncnstr$dir[i], ncnstr$rhs[i])
#	}
	opt = lp.control(lpfl, verbose="normal")
	return(lpfl)
}
set_lp_net_maxflow = function(lpfl, maxflow)
{
	sink_id = length(get.constr.type(lpfl))
	src_id = length(get.constr.type(lpfl)) - 1
	set.constr.value(sink_id, rsh = maxflow, constraints = c(sink_id, src_id))
}


#### this script:
##        for use change point estimation for phenological transition dates in Xie&Wilson RSE 2020
##

library(segmented)
library(foreach)
library(parallel)
library(doParallel)
library(dplyr)
library(raster)
library(ncdf4)

# set working directory
fmosaic=""          # folder of mosaic MODIS nc files
fevi=""             # folder of evi nc files
fdata=""            # relevant datasets
fseg=""             # output folder

# functions----------------------------------------------------------------------
# get twice daily netCDF files info
filesinfo <-function(fmosaic)
{
  fs=data.frame(path=list.files(fmosaic,full=T,pattern=".nc"),file=list.files(fmosaic,pattern=".nc"),stringsAsFactors=F) # build file list
  fs[,c("sensor","datecode")]=do.call("rbind",strsplit(fs$file,".",fixed=T))[,c(1,2)]
  fs$sensordate=paste(fs$sensor,fs$datecode,sep=".")
  fs$date=as.Date(substr(fs$file,10,16),"%Y%j")
  fs$month=format(fs$date,"%m")
  fs$year=format(fs$date,"%Y")
  fs$time=ifelse(fs$sensor=="MOD09GA","10:30","13:30")
  fs$datetime=as.POSIXct(paste(fs$date,fs$time))
  fs$dateid=format(fs$date,"%Y%m%d")
  return(fs)
}

# make input dataframe
makedf=function(EVI,doyt,...){
  data=cbind.data.frame(EVI=EVI,doyt=doyt)
  data=na.omit(data)
  return(data)
}

# change point estimation functions
seg_fun <- function(data,na.rm=TRUE,...)
{
  #profvis({
  #data=makedf(EVI,doyt)
  #return(data$EVI[1:5])
  evi.lm<-tryCatch(lm(EVI~doyt,data=data), error= function(e) return(0))    # catch error from all NAs
  if (class(evi.lm)[1]=="numeric") {
    return(rep(NA,23)) } else
    {
      #data=cbind.data.frame(EVI=EVI,doyt=doyt)
      #data=na.omit(data)
      spr=log_spr(data)       # logistic curve fitting for spring
      aut=log_aut(data)       # logistic curve fitting for autumn
      p=c(spr[5],spr[6],aut[5],aut[6])      # set logistic curve fitting results as initial estimation values
      evi.seg<-tryCatch(segmented(evi.lm,seg.Z=~doyt,psi=p,
                                  control=seg.control(toll = 1e-08, it.max=100, h=1, stop.if.error=T, n.boot=300)),
                        error= function(e) return(0))      # catch error from failed segmented function
      if (class(evi.seg)[1] == "numeric") {
        #print(paste("Segmented estimation Fail!",sep=""))
        return(rep(-9999,23))} else
        {
          #print(paste("Segmented estimation Succeed!",sep=""))
          df=numeric(23)
          df=c(c(evi.seg$psi[,c(2,3)]), c(intercept(evi.seg)$doyt), c(slope(evi.seg)$doyt[,c(1,2)]))
          #varnames=c("greenup","maturity","senescence","dormancy","greenup_se","maturity_se","senescence_se","dormancy_se",
          #           "intercept1","intercept2","intercept3","intercept4","intercept5",
          #           "slope1","slope2","slope3","slope4","slope5","slope1_se","slope2_se","slope3_se","slope4_se","slope5_se")
          #structure(df, names=varnames)
          return(df)      # return a vector with 23 numbers
        }
    }
  # })
}

# run code --------------------------------------------------------------------------
# read location information for 20000 pixels
grd=read.table(file=paste(fdata,"/loc_sample20000.csv",sep=""),header=T,sep= ",",stringsAsFactors=FALSE)

# read evi nc files (one nc file stores evi values of all pixels at one time point)
fs2=filesinfo(fmosaic)        # get files info
fs2=fs2[order(fs2$datetime),]

filenames=paste(fevi,"/",fs2$sensordate,"_evi_QAls.nc",sep="")
d=stack(x=c(filenames))            # read all files

# output 23 variable names
varnames=c("greenup","maturity","senescence","dormancy","greenup_se","maturity_se","senescence_se","dormancy_se",
           "intercept1","intercept2","intercept3","intercept4","intercept5",
           "slope1","slope2","slope3","slope4","slope5","slope1_se","slope2_se","slope3_se","slope4_se","slope5_se")

year=2000:2019

grd=modloc_grdob   # for ground observation sites
for (j in 1:19)
{
  # get time series of day and time including current year and January in next year
  datetime=c(fs2[which(fs2$year==year[j]),10], fs2[which(fs2$year==year[j+1] & fs2$month=="01"),10])
  if (j>1) doyt=as.numeric(datetime-as.POSIXct(paste(year[j],"-01-01",sep="")))/24 else
    doyt=as.numeric(datetime-as.POSIXct(paste(year[j],"-01-01",sep="")))
  bands=c(which(fs2$year==year[j]),which(fs2$year==year[j+1] & fs2$month=="01"))

  # extract evi for 20000 pixels
  df=extract(d,grd$cellid,df=T,layer=bands[1],n=length(bands))

  # parallel computation
  registerDoParallel(30)
  getDoParWorkers()

  # change point estimation
  seg <- foreach(i=1:length(grd$cellid), .combine='rbind.data.frame') %dopar%
    {
      EVI=as.numeric(df[i,-1])
      data=makedf(EVI,doyt)
      seg_fun(data)
    }

  # stop parallel workers
  stopCluster()

  # assign variable names
  colnames(seg)=varnames

  # save output for each year
  write.table(seg,file=paste(fseg,"/seg_",year[j],"_smp20000.csv",sep=""),row.names = F, sep=",")
}


# Script to explore the numerical consquences of changes the Euler integration
# step size.

library(rstan)
library(doParallel)
library(plyr)
library(magrittr)
library(lubridate)
library(ggplot2)
library(gridExtra)

# Loading and processing mosquito and case data

tseries <- read.csv("Data/Vitoria.data.csv")

data <- ddply(tseries, .(tot.week), summarise,
              obs = sum(Cases, na.rm = T),
              q = sum(Mosquitoes, na.rm = T),
              tau = sum(Trap, na.rm = T),
              year = unique(Year),
              week = unique(Week))

# Population size
pop <- 327801

# Wrangling weather data and computing EIP
weather <- read.csv("Data/Vitoria.weather.csv") %>%
  mutate(date = ymd(BRST), year = year(date), week = week(date))

weather <- subset(weather, date < date[1] + weeks(243))
weather$tot.week <- rep(c(1:243), each = 7)

covars <- ddply(weather, .(tot.week), summarise,
                temp = mean(Mean.TemperatureC, na.rm = T))

rov <- 7 * exp(0.2 * covars$temp - 8)

#===============================================================================
# Loading mcmc samples

fit <- readRDS("Results/gamma_eip_dv0.rds")

samples <- rstan::extract(fit)[1:17]

extract_sample <- function(x, k){
  if(length(dim(x)) == 1) return(x[k])
  else return(x[k, ])
}

# Selecting a sample to run the simulation with
init <- list(lapply(samples, extract_sample, 1))

# Loading Stan code
model <- stan_model(file = "Code/gammaeip.stan")

#===============================================================================
# Simulating dynamics with smaller and smaller Euler steps

# Number of Euler steps per week
steps <- c(7, 14, 28, 56, 112, 224)

# Loop over each of the step sizes and simulate dynamics
runs <- foreach(k = 1:6, .packages = c("rstan", "magrittr"), .combine = "rbind") %do% {

  dat.stan <- list(T = 243,
                   steps = steps[k],
                   y =data$obs,
                   q = data$q,
                   tau = data$tau,
                   rov = rov,
                   control = matrix(1, nrow = 243, ncol = 3),
                   pop = pop)

  sim <- sampling(model,
                  data = dat.stan,
                  init = init,
                  iter = 1,
                  chains = 1,
                  warmup = 0,
                  algorithm = "Fixed_param")

  cases <- diff(rstan::extract(sim, "state", permute = T)[[1]][1, , 11])

  return(cases)
}

#===============================================================================
# Compare number of cases per week for the different step sizes

plot(runs[6, ])
points(runs[5, ], pch = 20, col = "blue")

plot(runs[5, ])
points(runs[4, ], pch = 20, col = "blue")

plot(runs[4, ])
points(runs[3, ], pch = 20, col = "blue")

plot(runs[3, ])
points(runs[2, ], pch = 20, col = "blue")

plot(runs[2, ])
points(runs[1, ], pch = 20, col = "blue")


library(fgsea)
library(tmod)
source(file.path(PROJECT_DIR, "R/functions/load_sig.r"))

# load CD38 signature genes
fn.cd38.cor = file.path(PROJECT_DIR, "generated_data", "CHI", "robust_corr_all.genes.txt")
df.cd38.cor = fread(fn.cd38.cor, data.table=F)

# load gene stability
fn.stab = file.path(PROJECT_DIR, "generated_data", "CHI", "CHI_genes_stability.txt")
ge.stab = fread(fn.stab, data.table=F)

df.comb = left_join(df.cd38.cor, ge.stab, by="gene") %>%
  arrange(-cor.mean.sd.ratio)

# load genes from BTM modules
data(tmod)

for (mset in c("LI","DC")) {
  cat("\nProcessing", mset, "BTM gene sets. ISV cutoff: ")
imod = tmod$MODULES$SourceID==mset
genes.btm = tmod$MODULES2GENES[imod]

isv.seq = seq(0, 0.75, by=0.25)

isv.rank = df.comb$ISV
names(isv.rank) = df.comb$gene

# load("SLE/SLE.RData", verbose = T)
# sle.genes = rownames(SLE$dat)
# isle = toupper(df.comb$gene) %in% toupper(sle.genes)
# sum(isle)

l = list()
set.seed(123)
for(i in seq_along(isv.seq)) {
  cat(isv.seq[i],"")
  gi = df.comb$ISV >= isv.seq[i]
  cc.rank = df.comb$cor.mean.sd.ratio[gi]
  names(cc.rank) = df.comb$gene[gi]
  l[[paste0("ISV.",isv.seq[i])]] <- fgsea(genes.btm, cc.rank, nperm=10000, maxSize=500)
}

dn = file.path(PROJECT_DIR, "generated_data", "fgsea_with_btm_modules")
dir.create(dn, showWarnings = F)
fn.res = file.path(dn, sprintf("BTM.%s_genes_fgsea_results.rds", mset))
saveRDS(l, fn.res)
}


# Test whether acclimation temperature is important for upper thermal limits
require(lme4)

#################
# Read in data
#################

# Measurements of upper thermal tolerance
dat<-read.csv(file="./data/tmax_data/dataset_1_hotwater.csv", header=T)
	table(dat$used_for_thermal_safety_margin_analysis, dat$habitat_intertidal) # 102 marine, 249 terrestrial

	#process data####
	dat<-subset(dat, !habitat=="freshwater") #remove freshwater species
	dat<-subset(dat, !habitat_intertidal=="intertidal") #remove intertidal species
	dat<-subset(dat, !is.na(tmax) & !is.na(tmax_acc)) #remove missing data
	dat <- droplevels(dat)

###########################################
# Tmax model with acclimation temperature
###########################################

terr1 <- lmer(tmax~tmax_acc + tmax_metric + (1|Phylum/Class/Order/Family/Genus), data=dat, subset=habitat=='terrestrial')
	summary(terr1)
mari1 <- lmer(tmax~tmax_acc + tmax_metric + (1|Order/Family/Genus), data=dat, subset=habitat=='marine') #ignore phylum and class since invariant in this subset
	summary(mari1)

# predictions
l <- 20
pred_terr <- data.frame(tmax_acc=seq(0,50,length.out=l), tmax_metric=rep('crit', l))
pred_mari <- data.frame(tmax_acc=seq(0,50,length.out=l), tmax_metric=rep('crit', l))
pred_terr$tmax <- predict(terr1, newdata=pred_terr, re.form=NA) # re.form to ignore random effects
pred_mari$tmax <- predict(mari1, newdata=pred_mari, re.form=NA)

#############
# Plots
#############

quartz(width=8, height=5)
# pdf(width=8, height=5, file='figures/tmax_vs_tmax_acc_w_fit.pdf')
par(mfrow=c(1,2))
plot(tmax ~ tmax_acc, data=dat, subset=habitat=='terrestrial', main='Terrestrial', col=c('red', 'blue')[1+(dat$tmax_metric=='crit')])
	lines(tmax ~ tmax_acc, data=pred_terr, col='blue')
plot(tmax ~ tmax_acc, data=dat, subset=habitat=='marine', main='Marine', col=c('red', 'blue')[1+(dat$tmax_metric=='crit')])
	lines(tmax ~ tmax_acc, data=pred_mari, col='blue')

legend('bottomright', legend=c('leth', 'crit'), col=c('red', 'blue'), pch=1)

dev.off()


# PACKAGES
pacman::p_load(tidyverse, rio)
pacman::p_load(dabestr)
pacman::p_load(ggdist, patchwork)
pacman::p_load(ggpp, ggtext)

# IMPORT
d1 <- import("https://raw.githubusercontent.com/VIS-SIG/Wonderful-Wednesdays/master/data/2021/2021-10-13/WWW_example_minimal_clinical_improvement.csv") %>%
   mutate(id = row_number(), .before = everything()) %>%
   janitor::clean_names()

# EXPORT
d1 %>% export("C:/R/Wonderful-Wednesdays/2021-10-13/ww_mci.csv")

# RESHAPE & CALC
d2 <- d1 %>%
   pivot_longer(cols = c(total_score_baseline, total_score_follow_up)) %>%
   mutate(time = ifelse(name == "total_score_baseline","B","F"),
          cgi_f = factor(cgi_i, labels = c('Very much improved [1]',
                                           'Much improved [2]',
                                           'Minimally improved [3]',
                                           'No change [4]',
                                           'Minimally worse [5]',
                                           'Much worse [6]',
                                           'Very much worse [7]'))) %>%
   select(id, cgi_i, cgi_f, time, value) %>%
   nest_by(cgi_i, cgi_f) %>%
   mutate(dabest   = list(dabest(data,
                                 time, value,
                                 idx = c("B","F"),
                                 paired = TRUE, id.col = id) )) %>%
   mutate(mean_diff = list( mean_diff(dabest) ) )

# EXTRACT
d3 <- d2 %>%
   select(cgi_i, cgi_f, mean_diff) %>%
   mutate(change = mean_diff$data %>% list(),
          boot   = mean_diff$result$bootstraps) %>%
   select(-mean_diff)

# N's and nested graphs
n <- d2 %>%
   mutate(n = nrow(data)/2) %>%
   select(cgi_i, cgi_f, n) %>%
   ungroup() %>%
   mutate(n_sum = cumsum(n))

gg_p <- function(i){

   cols         <- as.vector(rep('gray90',7))
   cols[i]      <- 'gray25'

   ggplot(data = n,
          aes(x = n, y = '1', fill = fct_rev(cgi_f)   ) ) +
      geom_bar(stat = 'identity') +
      geom_label(data = n %>% slice(i),
                 aes(   x = n_sum,
                        y = '1',
                        label = n),
                 nudge_y = 0.40,
                 size = 3, fill = 'white',
                 label.padding = unit(0.10, "lines"), label.size = 0.0) +
      scale_fill_manual(values = rev(cols)) +
      guides(fill = 'none') +
      theme_void()
}

n <- n %>%
   rowwise() %>%
   mutate(gg = list( gg_p(cgi_i)))

# CHANGE
change <- d3 %>%
   select(cgi_i, cgi_f, change) %>%
   unnest(c(change))

f1 <- ggplot(data = change,
             aes(x = time, y = value, group = id)) +
   geom_plot_npc(data = n,
                 vp.width = 0.95, vp.height = 0.08,
                 aes(npcx = 0.01, npcy = 0.99,  label = gg)) +
   geom_line(col = 'gray25', alpha = 0.5, size = 0.5) +
   stat_summary(aes(group = 1),
                fun = mean, colour = 'black', geom='line', size = 1,
                position = position_nudge(x = c(-0.05, 0.05))) +
   stat_halfeye(data = . %>% filter(time == "B"),
                aes(group = 1),
                point_interval = mean_qi,
                side = 'left',
                justification = 1.1,
                adjust = 0.95,
                position = position_nudge(x = -0.1)) +
   stat_halfeye(data = . %>% filter(time == "F"),
                aes(group = 1),
                point_interval = mean_qi,
                side = 'right',
                justification = -0.1,
                adjust = 0.95,
                position = position_nudge(x = 0.1)) +
   scale_y_continuous(name = 'Better <----- Total Score -----> Worst',
                      expand = c(0,0),
                      limits = c(12, 80),
                      sec.axis = sec_axis(~., name = '')) +
   scale_x_discrete(name = '',
                    expand = c(0.05, 0.05),
                    labels = c("Baseline         ", "         Follow-up")) +
   facet_wrap(.~cgi_f, ncol = 7) +
   theme_bw() +
   theme(panel.grid.minor = element_blank(),
         panel.spacing    = unit(0, "lines"),
         plot.margin      = margin(b = 0))

# BOOSTRAP
boot <- d3 %>%
   select(cgi_i, cgi_f, boot) %>%
   unnest(c(boot))

m <- boot %>%
   group_by(cgi_f) %>%
   summarise(m = mean(boot) %>% round(1))

f2 <- ggplot(data = boot,
             aes(y = boot, x = 'Ch', fill = stat(abs(y) > 10) ) ) +
   stat_halfeye(point_interval = mean_qi,
                side = 'right',
                justification = -0.05,
                adjust = 0.8,
                position = position_nudge(x = 0.05)) +
   geom_hline(yintercept  = c(-10, 10),
              color = 'gray75') +
   geom_hline(yintercept = 0,
              color = 'gray50') +
   scale_fill_manual(values = c("gray80", "skyblue")) +
   scale_y_continuous(name = 'Paired Mean Difference \n (5K Bootstrap)',
                      limits = c(-20, 20),
                      expand = c(0, 0),
                      sec.axis = sec_axis(~., name = '')) +
   scale_x_discrete(name = '',
                    expand = c(0.15, 0),
                    labels = "F minus B") +
   facet_wrap(.~cgi_f, ncol = 7) +
   geom_text(data = m,
             aes(x = 'Ch', y = m, label = m),
             size = 3, nudge_x = 0.2
   ) +
   theme_bw() +
   theme(panel.grid.minor   = element_blank(),
         panel.grid.major.x = element_blank(),
         panel.spacing      = unit(0, "lines"),
         plot.margin        = margin(t = 0, b = 0),
         strip.text         = element_blank()) +
   guides(fill = 'none')

f1/f2 +
   plot_layout(heights = c(1.5,1)) +
   plot_annotation(
      title   =
      "Baseline, Follow-up and Change assessment of the total score by Clinical Assessment of Improvement (CGI-I)

      Top panel gray lines represent a participant score, while
      the slab and point interval (mean, 95% and 99% CI) characterize the marginal observations with
      top annotations for the total number of pairs.

      Bottom panel paired mean Change derived though nonparametric bootstrap resampling, mean difference
      ± than 10 are color-coded.
     ",
     theme = theme(
        plot.title = element_textbox_simple(
           size = 13,
           lineheight = 1,
           r = unit(5, "pt"),
           padding = margin(4, 4, 4, 4),
           margin  = margin(1, 20, 5, 1),
           fill = "gray90"
        )
     )
   )

ggsave("C:/R/Wonderful-Wednesdays/2021-10-13/ww_mci.png",
       dpi = 600,
       width = 14,
       height = 7)

posts/2021-12-05-wonderful-wednesdays-november-2021/code/ww_mci - Agustin Calatroni.r


################################################################################
# expectedHapFreq function  - (lines)
#
# Author: Heidi Lischer
# Date: 10.2008
################################################################################

expectedHapFreq <- function(xmlText, obsHapFrequency, timeAttr, popAttr,
                             outfile=outfiles){

  # convert string data (table with names) to a numeric matrix -----------------
  # split string --------
  tagData2 <- as.character(xmlText)

  tagData3 <- strsplit(tagData2, "\n")
  tagMatrix <- as.matrix(as.data.frame(tagData3))
  tagMatrix <- gsub(" + ", " ", tagMatrix)   # trim white space
  tagMatrix <- subset(tagMatrix, tagMatrix[,1] != "") #trim empty lines
  tagMatrix <- tagMatrix[7:(nrow(tagMatrix)-1)]
  Data <- strsplit(tagMatrix, " ")

  Row <- length(Data)-1

  # to numeric matrix -----------
  Matrix <- as.matrix(as.data.frame(Data[1]))
  Matrix <- subset(Matrix, Matrix[,1] != "")
  Matrix <- as.numeric(Matrix)
  numericMatrix <- t(as.matrix(Matrix))

  for(n in 2:(Row)){
    nextrow <- as.matrix(as.data.frame(Data[n]))
    nextrow <- subset(nextrow, nextrow[,1] != "")
    nextrow <- as.numeric(nextrow)
    numericMatrix <- rbind(numericMatrix, t(as.matrix(nextrow)))
  }
  numericMatrix <- numericMatrix[,2:3]

  # graphic --------------------------------------------------------------------
  expHapFrequency <- numericMatrix[,1]
  sdExp <- numericMatrix[,2]
  sdExpUp <- expHapFrequency + sdExp
  sdExpLo <- expHapFrequency - sdExp

  yMin <- min(obsHapFrequency, expHapFrequency, sdExpLo)
  yMax <- max(obsHapFrequency, expHapFrequency, sdExpUp)

  outfileGraphic <- paste(outfile, "obsExpHapFreq ", popAttr, "_", timeAttr,
                           ".png", sep="")

  #save graphic
  png(outfileGraphic, width=1300, height=1300, res=144)

    plot(obsHapFrequency, type="l", xlab="Allele", ylab="Relative frequency",
          ylim=c(yMin, yMax), main=paste("Haplotype Frequencies", popAttr,
          sep="\n"), lwd=2, xaxt="n")

      axis(1, 1:length(expHapFrequency), cex.axis=0.9)
      lines(expHapFrequency, col="red3")
      lines(sdExpUp, lty=2, col="red3")
      lines(sdExpLo, lty=2, col="red3")
      legend("topright", c("observed", "expected", "expected +/- 1 sd"),
             lty=c(1,1,2), lwd=c(2,1,1), bty="n", col=c("black", "red3", "red3"),
             cex=0.9)

  dev.off()

}


# Load necessary packages
library(tidyverse)

# Use readr to read the raw .tab file from GitHub
# Skip the lengthy metadata.
bfd <- read_tsv("https://raw.githubusercontent.com/phjacobs/foram_sdm/master/Data/Raw/BFD.tab", skip=1326)

# Remove '[m]', '[#]' and spaces
names(bfd) <- gsub(x = names(bfd), pattern = " \\[m\\]", replacement = "")
names(bfd) <- gsub(x = names(bfd), pattern = " \\[#\\]", replacement = "")
names(bfd) <- gsub(x = names(bfd), pattern = "\\.", replacement = "")
names(bfd) <- gsub(x = names(bfd), pattern = "\\(", replacement = "")
names(bfd) <- gsub(x = names(bfd), pattern = "\\)", replacement = "")
names(bfd) <- gsub(x = names(bfd), pattern = " ", replacement = "_")
names(bfd)

write_csv(bfd, "bfd_clean_01.csv")

### tidy the data
# First we use gather to breakout the taxa & count data
tidy.bfd <- bfd %>%
# Use select to ignore the irrelavant & summary columns
  select(1:3,7:10,12:14,16:42,44:51) %>%
# Use gather to breakout the taxa & count data
  gather(Taxa, Count, -Event, -Latitude, -Longitude)

head(tidy.bfd, 3)

write_csv(tidy.bfd, "bfd_tidy_01.csv")

##
# Need to calculate relative abundance, which is count of each taxa divided by total

##


library(ggplot2)
library(eulerr)

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

# Euler plotting is stochastic. This seed
# reaches a perfect fit.
set.seed(55)

# Values taken from intervene venn output
e <- euler(c(H33.ES=38509,
      H33.NS=61907,
      H3K9me3=52573,
      'H33.ES&H33.NS'=22010,
      'H33.ES&H3K9me3'=18735,
      'H33.NS&H3K9me3'=443,
      'H33.ES&H33.NS&H3K9me3'=278), shape='ellipse')

pdf(out, width=5, height=5)
plot(e, fills = list(fill = c("#f36972", "#f9b772", "#992e99"), alpha = 0.5), quantities=TRUE)
dev.off()


# _____ Initialize data ______
# Author: Mareva Brixy
# # Define training set and test set
# train_data = read.csv(file="ModelingTrain_train.csv")
# test_data = read.csv(file="ModelingTrain_test.csv")

# Read the data from the CSV file
data = read.csv(file="ModelingTrain.csv")

# Define the total number of samples
total_nb_samples = length(data[,1])

# Define the number of covariates
nb_covariates = length(data[1,])

# Drop the first column (ID)
data = data[,-1]

# Split the data into a training set and a test set
train_idx = sample(1:total_nb_samples, 0.75 * total_nb_samples)
train_data = data[train_idx,]
test_data = data[-train_idx,]
train_nb_samples = length(train_data[,1])
test_nb_samples = length(test_data[,1])

# Data as categorical data (only integer values)
for (i in 1:nb_covariates){
  train_data[,i] = as.factor(train_data[,i])
  test_data[,i] = as.factor(test_data[,i])
}

# For reproductibility
set.seed(4240)

# _____ Random Forest algorithm ______

# Import the library 'randomForest'
library(randomForest)

# Define the random forest : y is the variable of interest
random_forest = randomForest( y~., data = train_data,
                              ntry = 22, ntree = 100, importance = TRUE)

# Variable importance : assess the importance of the predictors
varImpPlot(random_forest)

# Make predictions on the test set
random_forest_prediction = predict(object = random_forest,
                                   newdata = test_data[, -1], type = "prob")

# Take the highest probability for each sample
random_forest_prediction_final = rep(0, test_nb_samples)
for (i in 1:test_nb_samples) {
  random_forest_prediction_final[i] = which.max(random_forest_prediction[i,]) - 1
}

# Calculate the accuracy
random_forest_accuracy = mean(random_forest_prediction_final == test_data[,1])


source("init.r")

api <- DefaultApi$new()

all.users.id <- api$read_users()$content$id

department.people.count <- list()

for (i in all.users.id) {
    u <- api$read_user(i)$content
    dept <- u$department
    if (!(dept %in% names(department.people.count))) {
        department.people.count[[ dept ]] <- 0
    }

    department.people.count[[ dept ]] <- department.people.count[[ dept ]] + 1
}

barplot(unlist(department.people.count), main="Employee count per department")


demo(graphics)

# El lienzo donde graficar
par(bg="grey98")
plot(1:100, type="n", axes=F, xlab = "", ylab="", bg="white")
rect(-10, -10, 120, 120, col="white")
box(lty = 3)
mtext(c("side = 1", "side = 2", "side = 3", "side = 4"),
side = c(1, 2, 3, 4), col = "grey", line = 1, cex = 1.5)

dev.off()

par(bg="grey98",mar=c(3,3,3,3))
layout.show()

par(bg="grey98",mar=c(3,3,3,3),mfcol=c(1,2))
layout.show()

# Dividiendo el lienzo
layout(matrix(c(1,2,3,3),2,2))
par(mar=c(1,1,1,1),bg="grey98")
layout.show()

# Controlando el tamaño
l = layout(matrix(c(1,1,2,3),2,2,byrow =TRUE),
       widths = c(2,3),heights = c(1.5,3))
par(mar=c(1,1,1,1),oma=c(3,3,1,1),bg="grey98")
layout.show(l)

# Parámetros gráficos
par(mar=c(1,1,1,1),oma=c(3,3,1,1),bg="grey98",mfcol=c(2,2))

# Los puntos
x <- rep(1:5,5)
y <- sort(rep(1:5,5))
par(mar=c(1,1,1,1))
plot(x,y,pch=1:25,col=1:5,cex=seq(1,3,length.out =25),bg="yellow",
     axes=FALSE,xlab="",ylab="",ylim=c(0,6))
text(x,y-0.3,cex=0.8)

library(png)
##Leerlo del disco duro
coli <- readPNG("Bird.png")
#Leerlo de internet y guardarlo
pngURL <-"http://www.pngall.com/wp-content/uploads/4/Single-Flying-Bird.png"
download.file(pngURL,"birdD.png",mode ="wb")


#' @param bins numeric vector giving number of bins in both vertical and
#'   horizontal directions. Set to 30 by default.
#' @param binwidth Numeric vector giving bin width in both vertical and
#'   horizontal directions. Overrides `bins` if both set.
#' @param drop if `TRUE` removes all cells with 0 counts.
#' @export
#' @rdname geom_bin_2d
#' @section Computed variables:
#' \describe{
#'   \item{count}{number of points in bin}
#'   \item{density}{density of points in bin, scaled to integrate to 1}
#'   \item{ncount}{count, scaled to maximum of 1}
#'   \item{ndensity}{density, scaled to maximum of 1}
#' }
stat_bin_2d <- function(mapping = NULL, data = NULL,
                        geom = "tile", position = "identity",
                        ...,
                        bins = 30,
                        binwidth = NULL,
                        drop = TRUE,
                        na.rm = FALSE,
                        show.legend = NA,
                        inherit.aes = TRUE) {
  layer(
    data = data,
    mapping = mapping,
    stat = StatBin2d,
    geom = geom,
    position = position,
    show.legend = show.legend,
    inherit.aes = inherit.aes,
    params = list(
      bins = bins,
      binwidth = binwidth,
      drop = drop,
      na.rm = na.rm,
      ...
    )
  )
}

#' @export
#' @rdname geom_bin_2d
#' @usage NULL
stat_bin2d <- stat_bin_2d

#' @rdname ggplot2-ggproto
#' @format NULL
#' @usage NULL
#' @export
StatBin2d <- ggproto("StatBin2d", Stat,
  default_aes = aes(weight = 1, fill = after_stat(count)),
  required_aes = c("x", "y"),

  compute_group = function(data, scales, binwidth = NULL, bins = 30,
                           breaks = NULL, origin = NULL, drop = TRUE) {

    origin <- dual_param(origin, list(NULL, NULL))
    binwidth <- dual_param(binwidth, list(NULL, NULL))
    breaks <- dual_param(breaks, list(NULL, NULL))
    bins <- dual_param(bins, list(x = 30, y = 30))

    xbreaks <- bin2d_breaks(scales$x, breaks$x, origin$x, binwidth$x, bins$x)
    ybreaks <- bin2d_breaks(scales$y, breaks$y, origin$y, binwidth$y, bins$y)

    xbin <- cut(data$x, xbreaks, include.lowest = TRUE, labels = FALSE)
    ybin <- cut(data$y, ybreaks, include.lowest = TRUE, labels = FALSE)

    if (is.null(data$weight))
      data$weight <- 1

    out <- tapply_df(data$weight, list(xbin = xbin, ybin = ybin), sum, drop = drop)

    xdim <- bin_loc(xbreaks, out$xbin)
    out$x <- xdim$mid
    out$width <- xdim$length

    ydim <- bin_loc(ybreaks, out$ybin)
    out$y <- ydim$mid
    out$height <- ydim$length

    out$count <- out$value
    out$ncount <- out$count / max(out$count, na.rm = TRUE)
    out$density <- out$count / sum(out$count, na.rm = TRUE)
    out$ndensity <- out$density / max(out$density, na.rm = TRUE)
    out
  }
)

dual_param <- function(x, default = list(x = NULL, y = NULL)) {
  if (is.null(x)) {
    default
  } else if (length(x) == 2) {
    if (is.list(x) && !is.null(names(x))) {
      x
    } else {
      list(x = x[[1]], y = x[[2]])
    }
  } else {
    list(x = x, y = x)
  }
}

bin2d_breaks <- function(scale, breaks = NULL, origin = NULL, binwidth = NULL,
                      bins = 30, right = TRUE) {
  # Bins for categorical data should take the width of one level,
  # and should show up centered over their tick marks. All other parameters
  # are ignored.
  if (scale$is_discrete()) {
    breaks <- scale$get_breaks()
    return(-0.5 + seq_len(length(breaks) + 1))
  } else {
    if (!is.null(breaks)) {
      breaks <- scale$transform(breaks)
    }
  }

  if (!is.null(breaks))
    return(breaks)

  range <- scale$get_limits()

  if (is.null(binwidth) || identical(binwidth, NA)) {
    binwidth <- diff(range) / bins
  }
  if (!(is.numeric(binwidth) && length(binwidth) == 1)) abort("`binwidth` must be a numeric scalar")

  if (is.null(origin) || identical(origin, NA)) {
    origin <- round_any(range[1], binwidth, floor)
  }
  if (!(is.numeric(origin) && length(origin) == 1)) abort("`origin` must be a numeric scalar")

  breaks <- seq(origin, range[2] + binwidth, binwidth)

  # Check if the last bin lies fully outside the range
  if (length(breaks) > 1 && breaks[length(breaks) - 1] >= range[2]) {
    breaks <- breaks[-length(breaks)]
  }

  adjust_breaks(breaks, right)
}

adjust_breaks <- function(x, right = TRUE) {
  diddle <- 1e-07 * stats::median(diff(x))
  if (right) {
    fuzz <- c(-diddle, rep.int(diddle, length(x) - 1))
  } else {
    fuzz <- c(rep.int(-diddle, length(x) - 1), diddle)
  }
  sort(x) + fuzz
}

bin_loc <- function(x, id) {
  left <- x[-length(x)]
  right <- x[-1]

  list(
    left = left[id],
    right = right[id],
    mid = ((left + right) / 2)[id],
    length = diff(x)[id]
  )
}


#' squaresPack
#'
#' The squaresPack package performs simple arithmetic calculations.
#' @name squaresPack
#' @docType package
#' @author  Ryan T. Moore: \email{rtm@@wustl.edu} and
#'   Jacob M. Montgomery: \email{jacob.montgomery@@wustl.edu}
#' @examples
#'
#' \dontrun{
#' demo(addSquares)
#' demo(subtractSquares)
#' }
#'
NULL

20220328 - S4 Classes/squaresPack/R/squaresPack-package.r


#Fitting a model with gjam.
library(gjam)
library(data.table)

#load data
d <- data.table(readRDS('/fs/data3/caverill/NEFI_microbial/prior_data/ted_all_prior_data.rds'))

#fit a gjam, intercept only, to ecto abundance.

#problem- sum of ecto + spro is grater than 1, because some are listed as both. Gotta deal with this in data cleaning ahead of this.
#specify your y dependent variable matrix of species abundances
spp.y <- data.frame(d$Ectomycorrhizal,d$Saprotroph)
#get an other column, cause things need to sum to 1.
spp.y$S3other <- 1 - (rowSums(spp.y))

#make x data.
spp.x <- data.frame(1, d$pH)
colnames(spp.x) <- c('intercept','x1')

#get a vector declaring the species abundance data types. Here we want fractional composition, FC.
#for some reason this work swith the sim genenrated stuff, but not my list...
types <- c('FC','FC','FC')
sim <- gjamSimData(S = 3, typeNames = 'FC')

#get a formula.
g.formula <- as.formula(~ x1)

#make model
m1 <- list(ng = 50, burnin = 5, typeNames = sim$typeNames)

#works. Now how do we extract species interactions from this?
test <- gjam(g.formula, spp.x, spp.y, modelList = m1)