#' Function used to perform experiments, given a quantifier method, varyng the test size and the class distribution
#'
#' Given a quantifier method (qntMethod), a classifier, and a test set, that function extract from the test set several
#' subsets varying the size and for each size the class distribution is also varied
#' @author Andre G Maletzke - andregustavom at gmail.com
#' @param test data.frame containing the test set
#' @param qntMethod the quantifier algorithm name
#' @param classifier A classifier built on a training set
#' @return The class distribution for each simulated subset extracted from the test set
#' @export

run_qntMethod_over_dataset_QT <- function(test, qntMethod, classifier, dts_id){

  var_perc <- seq(0,1,0.01)                       # range of values used to evaluate the impact of class distribution on error
  var_size <- c(seq(10,100,10), seq(200,500,100)) # range of test set sizes
  n_tests  <- 10                                  # for each combination of var_perc and var_size we build n_tests aleatory scenarios

  results     <- NULL

  idx_pos <- which(test$class==1) # positive class (1)
  idx_neg <- which(test$class==2) # negative class (2)

  if(!dir.exists(paste0("./tmp_", qntMethod)))
    dir.create(paste0("./tmp_", qntMethod))

  if(!dir.exists(paste0("./tmp_",qntMethod,"/", dts_id)))
    dir.create(paste0("./tmp_",qntMethod,"/", dts_id))

  if(!dir.exists(paste0("./test_QT/",dts_id)))
    dir.create(paste0("./test_QT/",dts_id))

  for(k in 1:length(var_size)){
    if(file.exists(paste0("./tmp_",qntMethod,"/", dts_id, "/", var_size[k], ".rds"))){
      print(paste0("Load data of size", var_size[k]))
      auxre <- readRDS(paste0("./tmp_",qntMethod,"/", dts_id, "/", var_size[k], ".rds"))
      results <- rbind(results, auxre)
    }else{
      print(paste0("Test size ", var_size[k]))
      for(i in 1:length(var_perc)){
        for(j in 1:n_tests){
          n_pos <- round(i*k)
          n_neg <- k - n_pos
          test_set <- rbind(test[sample(idx_pos,n_pos),], test[sample(idx_neg,n_neg),])

          pp <- which(test_set$class==1)
          nca <- 1:nrow(test_set)

          if(length(pp)==0){
            nca[] <- 1
          }else{
            nca[pp] <- 0
            nca[-pp] <- 1
          }

          nn <- names(test_set)
          test_set <- test_set[,-1]
          test_set <- cbind(nca,test_set)
          names(test_set) <- nn

          test_set$class <- factor(test_set$class, levels=c("0", "1"))
          nn <- names(test_set)
          nn <- c(nn[-1], nn[1])
          test_set <- cbind(test_set[,-1], test_set[,1])
          names(test_set) <- nn

          write.arff(test_set, paste0("./test_QT/",dts_id,"/test_set",".arff"))
          command <- paste0("java  -Xmx5G -cp quantify.jar:weka.jar:. weka.classifiers.trees.RandomForest -l ./models_train_test/",dts_id, "/", classifier,
                            " -T ", "./test_QT/",dts_id,"/test_set",".arff")
          system(paste0(command," > ", "./test_QT/",dts_id,"/","re.txt"))
          x <- read.delim(paste0("./test_QT/",dts_id,"/","re.txt"))

          pos <- as.vector(na.omit(as.numeric(strsplit(as.character(x[4,])," ")[[1]])))[1]
          pos <- pos + as.vector(na.omit(as.numeric(strsplit(as.character(x[5,])," ")[[1]])))[1]
          pos <- pos/nrow(test_set)
          freq_PRE <- as.data.frame(round(cbind(pos, 1-pos),2))
          names(freq_PRE) <- c("1", "2")
          freq_REAL<- table(test_set$class)/sum(table(test_set$class))
          results  <- rbind(results, unlist(c(freq_REAL,
                                              freq_PRE,
                                              round(abs(freq_REAL[1]-freq_PRE[1]),2),
                                              nrow(test_set),
                                              qntMethod)))
          browser()
        }
      }
      saveRDS(results[which(results[,6]==var_size[k]),], paste0("./tmp_",qntMethod,"/", dts_id, "/", var_size[k], ".rds"))
    }

  }
  results <- as.data.frame(results)
  names(results) <- c(paste("R", as.character(1:2), sep="_"),
                      paste("P", as.character(1:2), sep="_"),
                      "MAE-C1",
                      "Test_Size",
                      "Qnt")
  return(results)
}


test_that("expand_scale() produces a deprecation warning", {
  expect_warning(expand_scale(), "deprecated")
})

test_that("expansion() checks input", {
  expect_snapshot_error(expansion(mult = 2:4))
  expect_snapshot_error(expansion(add = 2:4))
})

# Expanding continuous scales -----------------------------------------

test_that("expand_limits_continuous() can override limits", {
  expect_identical(expand_limits_continuous(c(1, 2), coord_limits = c(NA, NA)), c(1, 2))
  expect_identical(expand_limits_continuous(c(1, 2), coord_limits = c(NA, 3)), c(1, 3))
  expect_identical(expand_limits_continuous(c(1, 2), coord_limits = c(0, NA)), c(0, 2))
})

test_that("expand_limits_continuous() expands limits", {
  expect_identical(expand_limits_continuous(c(1, 2), expand = expansion(add = 1)), c(0, 3))
})

test_that("expand_limits_continuous() expands coord-supplied limits", {
  expect_identical(
    expand_limits_continuous(c(1, 2), coord_limits = c(0, 4), expand = expansion(add = 1)),
    c(-1, 5)
  )
})

test_that("expand_limits_continuous_trans() expands limits in coordinate space", {
  limit_info <- expand_limits_continuous_trans(
    c(1, 2),
    expand = expansion(add = 0.5),
    trans = log10_trans()
  )

  expect_identical(
    limit_info$continuous_range,
    10^(expand_range4(log10(c(1, 2)), expansion(add = 0.5)))
  )

  expect_identical(
    limit_info$continuous_range_coord,
    expand_range4(log10(c(1, 2)), expansion(add = 0.5))
  )
})

test_that("introduced non-finite values fall back on scale limits", {
  limit_info <- expand_limits_continuous_trans(
    c(1, 100),
    expand = expansion(add = 2),
    trans = sqrt_trans()
  )

  expect_identical(limit_info$continuous_range, c(1, (sqrt(100) + 2)^2))
  expect_identical(limit_info$continuous_range_coord, c(-1, sqrt(100) + 2))
})

# Expanding discrete scales -----------------------------------------

test_that("expand_limits_discrete() can override limits with an empty range", {
  expect_identical(expand_limits_discrete(NULL, coord_limits = c(-1, 8)), c(-1, 8))
})

test_that("expand_limits_discrete() can override limits with a discrete range", {
  expect_identical(expand_limits_discrete(c("one", "two"), coord_limits = c(NA, NA)), c(1, 2))
  expect_identical(expand_limits_discrete(c("one", "two"), coord_limits = c(NA, 3)), c(1, 3))
  expect_identical(expand_limits_discrete(c("one", "two"), coord_limits = c(3, NA)), c(3, 2))
})

test_that("expand_limits_discrete() can override limits with a continuous range", {
  expect_identical(
    expand_limits_discrete(NULL, coord_limits = c(NA, NA), range_continuous = c(1, 2)),
    c(1, 2)
  )
  expect_identical(
    expand_limits_discrete(NULL, coord_limits = c(NA, 3), range_continuous = c(1, 2)),
    c(1, 3)
  )
  expect_identical(
    expand_limits_discrete(NULL, coord_limits = c(0, NA), range_continuous = c(1, 2)),
    c(0, 2)
  )
})

test_that("expand_limits_discrete() can override limits with a both discrete and continuous ranges", {
  expect_identical(
    expand_limits_discrete(c("one", "two"), coord_limits = c(NA, NA), range_continuous = c(1, 2)),
    c(1, 2)
  )
  expect_identical(
    expand_limits_discrete(c("one", "two"), coord_limits = c(NA, 3), range_continuous = c(1, 2)),
    c(1, 3)
  )
  expect_identical(
    expand_limits_discrete(c("one", "two"), coord_limits = c(0, NA), range_continuous = c(1, 2)),
    c(0, 2)
  )
})

test_that("expand_limits_continuous_trans() works with inverted transformations", {
  limit_info <- expand_limits_continuous_trans(
    c(1, 2),
    expand = expansion(add = 1),
    trans = reverse_trans()
  )

  expect_identical(limit_info$continuous_range, c(0, 3))
  expect_identical(limit_info$continuous_range_coord, c(0, -3))
})

test_that("expand_limits_scale_discrete() begrudgingly handles numeric limits", {
  expect_identical(
    expand_limits_discrete(
      -1:-16,
      coord_limits = c(NA, NA),
      range_continuous = c(-15, -2)
    ),
    c(-15, -2)
  )
})


# 0_initialize.r
# Last updated 20190822

# checkpoint will look for (and, if necessary, install)
# packages from the snapshot date
library(checkpoint)
checkpoint("2018-11-25")

library(here) # set top level of current project
library(tidyverse) # mutate, filter, etc
library(broom) # tidy
library(geepack) #geeglm
library(imputeTS) # na.replace
library(conflicted) # conflict_prefer
library(arm) # rescale

# This function is adapted from Dustin Fife's "fifer" package, which is not
# on MRAN/CRAN but is available at https://github.com/dustinfife/fifer
chisq.post.hoc <- function(
    tbl,
    test=c("fisher.test"),
    popsInRows=TRUE,
    control=c("fdr","BH","BY","bonferroni","holm","hochberg","hommel"),
    digits=4, ...) {
        control <- match.arg(control) # extract correction method
        test = match.fun(test) # extract which test (fisher or chi square)

        if (!popsInRows) tbl <- t(tbl)  # test rows or columns
        popsNames <- rownames(tbl)

        prs <- combn(1:nrow(tbl),2) # come up with all possible comparisons

        tests <- ncol(prs) # preallocate
        pvals <- numeric(tests)
        lbls <- character(tests)

        for (i in 1:tests) {
            pvals[i] <- test(tbl[prs[,i],], ...)$p.value
            lbls[i] <- paste(popsNames[prs[,i]],collapse=" vs. ")
        }

        adj.pvals <- p.adjust(pvals,method=control)
        cat("Adjusted p-values used the",control,"method.\n\n")
        data.frame(
            comparison=lbls,
            raw.p=round(pvals,digits),
            adj.p=round(adj.pvals,digits))
}

# These scripts pull data from two sources. "SVIP_CLEAN" is the
# location of the extracted `Simons_VIP__16p11.2_Dataset_v10.0`
# archive downloadable from the SFARI Base portal. "SVIP_RAW"
# is the location of a single raw CSV file containing M-SOPS data,
# which was not part of the "clean" data release, but which we received
# by request from the Simons Foundation.
SVIP_CLEAN <- here("data","clean","Simons_VIP__16p11.2_Dataset_v10.0")
SVIP_RAW <- here("data","raw","sops.csv")

# Give dplyr namespace priority
conflict_prefer("filter", "dplyr")
conflict_prefer("select", "dplyr")

# Pull in data
source(here("r","1_import.r"))

# Derive ADOS RRB and SA Calibrated Severity Scores
source(here("r","2_derive_ados_domain_css.r"))

# Derive index of positive psychotic symptoms
source(here("r","3_derive_psychosis_index.r"))

# Create groups for regressions
source(here("r","4_create_analysis_groups.r"))

# Run analyses and save data as series of CSV files
source(here("r","5_run_analyses.r"))


#!/usr/bin/r

suppressMessages(require(Rcpp))
set.seed(42)
n <- 200
a <- rnorm(n)
b <- rnorm(n)

## load shared libraries with wrapper code
dyn.load("convolve2_c.so")
dyn.load("convolve3_cpp.so")
dyn.load("convolve4_cpp.so")
dyn.load("convolve5_cpp.so")
dyn.load("convolve7_c.so")

dyn.load("convolve8_cpp.so")
dyn.load("convolve9_cpp.so")
dyn.load("convolve10_cpp.so")
dyn.load("convolve11_cpp.so")
dyn.load("convolve12_cpp.so" )
dyn.load("convolve14_cpp.so" )

## now run each one once for comparison of results,
## and define test functions

R_API_optimised <- function(n,a,b) .Call("convolve2__loop", n, a, b)
Rcpp_New_std <- function(n,a,b) .Call("convolve3cpp__loop", n, a, b)
#Rcpp_New_std_inside <- function(n,a,b) .Call("convolve3cpp__loop", n, a, b, PACKAGE = "Rcpp" )
Rcpp_New_ptr <- function(n,a,b) .Call("convolve4cpp__loop", n, a, b)
Rcpp_New_sugar <- function(n,a,b) .Call("convolve5cpp__loop", n, a, b)
Rcpp_New_sugar_noNA <- function(n,a,b) .Call("convolve11cpp__loop", n, a, b)
R_API_naive <- function(n,a,b) .Call("convolve7__loop", n, a, b)
Rcpp_New_std_2 <- function(n,a,b) .Call("convolve8cpp__loop", n, a, b)
#Rcpp_New_std_3 <- function(n,a,b) .Call("convolve9cpp__loop", n, a, b)
#Rcpp_New_std_4 <- function(n,a,b) .Call("convolve10cpp__loop", n, a, b)
Rcpp_New_std_it <- function(n,a,b) .Call("convolve12cpp__loop", n, a, b )
Rcpp_New_std_Fast <- function(n,a,b) .Call("convolve14cpp__loop", n, a, b )

v1 <- R_API_optimised(1L, a, b )
v3 <- Rcpp_New_std(1L, a, b)
v4 <- Rcpp_New_ptr(1L, a, b)
v5 <- Rcpp_New_sugar(1L, a, b )
v7 <- R_API_naive(1L, a, b)
v11 <- Rcpp_New_sugar_noNA(1L, a, b)

stopifnot(all.equal(v1, v3))
stopifnot(all.equal(v1, v4))
stopifnot(all.equal(v1, v5))
stopifnot(all.equal(v1, v7))
stopifnot(all.equal(v1, v11))

## load benchmarkin helper function
suppressMessages(library(rbenchmark))
REPS <- 5000L
bm <- benchmark(R_API_optimised(REPS,a,b),
                R_API_naive(REPS,a,b),
                Rcpp_New_std(REPS,a,b),
#                Rcpp_New_std_inside(REPS,a,b),
                Rcpp_New_ptr(REPS,a,b),
                Rcpp_New_sugar(REPS,a,b),
                Rcpp_New_sugar_noNA(REPS,a,b),
                Rcpp_New_std_2(REPS,a,b),
#                Rcpp_New_std_3(REPS,a,b),
#                Rcpp_New_std_4(REPS,a,b),
		Rcpp_New_std_it(REPS,a,b),
		Rcpp_New_std_Fast(REPS,a,b),
                columns=c("test", "elapsed", "relative", "user.self", "sys.self"),
                order="relative",
                replications=1)
print(bm)

cat("All results are equal\n") # as we didn't get stopped
q("no")

sizes <- 1:10*100
REPS <- 5000L
timings <- lapply( sizes, function(size){
    cat( "size = ", size, "..." )
    a <- rnorm(size); b <- rnorm(size)
    bm <- benchmark(R_API_optimised(REPS,a,b),
                R_API_naive(REPS,a,b),
                Rcpp_New_std(REPS,a,b),
                Rcpp_New_ptr(REPS,a,b),
                Rcpp_New_sugar(REPS,a,b),
                Rcpp_New_sugar_noNA(REPS,a,b),
                columns=c("test", "elapsed", "relative", "user.self", "sys.self"),
                order="relative",
                replications=1)

     cat( "  done\n" )
     bm
} )
for( i in seq_along(sizes)){
    timings[[i]]$size <- sizes[i]
}
timings <- do.call( rbind, timings )

require( lattice )
png( "elapsed.png", width = 800, height = 600 )
xyplot( elapsed ~ size, groups = test, data = timings, auto.key = TRUE, type = "l", lwd = 2 )
dev.off()
png( "relative.png", width = 800, height = 600 )
xyplot( relative ~ size, groups = test, data = timings, auto.key = TRUE, type = "l", lwd = 2 )
dev.off()


#' Diffusion regression model
#'
#' A wrapper of \code{glm}, this function estimates a lagged regression model of
#' adoption as a function of exposure and other controls as especified by the
#' user.
#'
#' @param model An object of class formula where the right-hand-side is an object of
#' class \code{\link[=diffnet]{diffnet}}
#' @param type Character scalar. Either \code{"probit"} or \code{"logit"}.
#' @details
#' The model must be in the following form:
#'
#' \preformatted{
#' <diffnet object> ~ exposure + covariate1 + covariate2 + ...
#' }
#'
#' Where \code{exposure} can be especified either as a simple term, or as a
#' call to the exposure function, e.g. to compute exposure with a lag of
#' length 2, the formula could be:
#'
#' \preformatted{
#' <diffnet object> ~ exposure(lags = 2) + covariate1 + covariate2 + ...
#' }
#'
#' When no argument is passed to \code{exposure}, the function sets a lag
#' of length 1 by default (see the \emph{Lagged regression} section).
#'
#' This is a wrapper of \code{\link[stats:glm]{glm}}. The function does the
#' following steps:
#' \enumerate{
#'  \item Compute exposure by calling \code{exposure} on the LHS (dependent variable).
#'  \item Modify the formula so that the model is on adoption as a function of
#'  exposure and whatever covariates the user specifies.
#'  \item Selects either \code{"probit"} or \code{"logit"} and prepares the call
#'  to \code{glm}. This includes passing the following line:
#'  \preformatted{
#'  subset = ifelse(is.na(toa), TRUE, toa >= per)
#'  }
#'  This results in including observations that either did not adopted or up to
#'  the time of adoption.
#'  \item Estimates the model.
#' }
#'
#' The data passed to \code{glm} is obtained by using \code{\link{as.data.frame.diffnet}}.
#'
#' @section Lagged regression:
#'
#' The model estimated is a lagged regression model that has two main assumptions:
#' \enumerate{
#' \item The network is exogenous to the behavior (no selection effect)
#' \item The influence effect (diffusion) happens in a lagged fasion, hence,
#' exposure is computed lagged.
#' }
#'
#' If either of these two assumptions is not met, then the model becomes endogenous,
#' ans so inference becomes invalid.
#'
#' In the case of the first assumption, the user can overcome the non-exogeneity
#' problem by providing an alternative network. This can be done by especifying
#' \code{alt.graph} in the \code{exposure} function so that the network becomes
#' exogenous to the adoption.
#'
#' @return
#' An object of class \code{\link[stats:glm]{glm}}.
#' @examples
#' data("medInnovationsDiffNet")
#'
#' # Default model
#' ans <- diffreg(
#'   medInnovationsDiffNet ~ exposure + factor(city) + proage + per)
#' summary(ans)
#' @export
diffreg <- function(model, type=c("logit", "probit")) {

  # Checks ---------------------------------------------------------------------

  # It must be a formula
  if (!inherits(model, "formula"))
    stop("Not a formula. `model` should be a formula in the form of <diffnet object> ~ exposure + ...", call. = FALSE)

  # Get the terms and checking whether exposure is present
  terms <- stats::terms.formula(model)
  labs  <- attr(terms, "term.labels")
  test  <- which(grepl("^exposure(\\(|$)", labs))

  if (!length(test))
    stop("No `exposure` term in the formula. The `diffreg` should include `exposure` on the RHS of the formula.", call. = FALSE)

  exposure_term <- labs[test]

  # Fetching the diffnet
  LHS <- attr(terms, "variables")[[2]]

  if (!inherits(eval(LHS), "diffnet"))
    stop("The LHS of the formula (dependent variable) is not a `diffnet` object. `diffreg` is only for `diffnet` objects.",
         call. = FALSE)

  # Updating the formula -------------------------------------------------------
  # Now the model will be Adopt ~ Exposure + ...
  model_call <- stats::update.formula(model, paste("~", exposure_term, "+."))
  model <- stats::update.formula(
    stats::update.formula(model, paste("Adopt ~ + . -", exposure_term)),
    ~ exposure + .
    )

  # Computing exposure ---------------------------------------------------------
  exposure_term <- attr(terms, "variables")[[test + 2L]]

  # Replacing the network object
  if (!is.call(exposure_term)) {
    exposure_term <- as.call(list(exposure_term, graph = LHS, lags = 1L))
  } else {
    if (is.null(exposure_term$lags) || exposure_term$lags < 1L)
      warning(
        "When the model is not lagged, i.e. is not `exposure(..., lags = 1L)`, ",
        "the model becomes endogenous, so inference is invalid."
      )
    exposure_term$graph <- LHS
  }

  exposure_term <- eval(exposure_term)

  dat <- eval(LHS)
  dat[["exposure"]] <- exposure_term
  dat[["Adopt"]]    <- dat$cumadopt
  dat <- as.data.frame(dat)

  # Some warnings
  if (!any(grepl("^(factor\\()?per", labs)))
    warning(
      "The variable `per` is not included in the model. ",
      "This can bias the `exposure` as adoption naturally increases over time.",
      call. = FALSE
      )

  # Making the call ------------------------------------------------------------

  ans <- call(
    "glm", noquote(model), data=quote(dat),
    subset = quote(ifelse(is.na(toa), TRUE, toa >= per))
    )

  if (all(type == c("logit", "probit")))
    type <- "logit"

  if (type == "probit")
    ans$family <- quote(binomial(link = "probit"))
  else if (type == "logit")
    ans$family <- quote(binomial(link = "logit"))
  else
    stop("The model of type `", type, "` is not supported.", call. = FALSE)

  eval(ans)

}


install.packages(c("gplots", "lme4", "reshape", "reshape2",
                   "ggplot2", "ggrepel", "data.table", "dplyr", "tidyr",
                   "survival", "doSNOW", "snow", "foreach", 'stringr',
                   "randomForest", "minpack.lm", "optparse"),
                 repos='http://cran.us.r-project.org')

if (!requireNamespace("BiocManager", quietly = TRUE))
    install.packages("BiocManager", repos='http://cran.us.r-project.org')
BiocManager::install("MSstats")


# Copyright Syncfusion Inc. 2001 - 2016. All rights reserved.
# Use of this code is subject to the terms of our license.
# A copy of the current license can be obtained at any time by e-mailing
# licensing@syncfusion.com. Any infringement will be prosecuted under
# applicable laws.

# If you are not familiar with R you can obtain a quick introduction by downloading
# R Succinctly for free from Syncfusion - http://www.syncfusion.com/resources/techportal/ebooks/rsuccinctly
# R Succinctly is also included with this installation and is available here
# Installed Drive :\Program Files (x86)\Syncfusion\Essential Studio\XX.X.X.XX\Infrastructure\EBooks\R_Succintly.pdf OF R Succinctly
# Uncomment below lines to install necessary packages if not installed already
# install.packages("e1071")
# install.packages("pmml")
# install.packages("gmodels")
# install.packages("rattle")

# Load below packages
library(e1071)
library(pmml)
library(gmodels)
library(rattle.data) # This package is specifically loaded for wine dataset shipped within it.

# Here we directly load the wine dataset installed with the "rattle" package.
data(wine)

# rename column names in wine dataset from rattle.data package
wineOriginal <- setNames(wine, c("Type", "Alcohol", "Malic_Acid","Ash","Alcalinity","Magnesium","Phenols","Flavanoids","Non_Flavanoids","Proanthocyanins","Color_Intensity","Hue","Dilution","Proline"))

# Omit rows with missing values
wineOriginal <- na.omit(wineOriginal)

# Code below demonstrates loading the same dataset from a CSV file shipped with our installer.
# Please check installed samples (Data) location to set actual working directory
# Uncomment below lines and comment out the code to read data from CSV file.
# setwd("C:/actual_data_location")
# wine<- read.csv("Wine.csv")

# Considering integer variable as factor
wineOriginal$Type <- factor(wineOriginal$Type, ordered = FALSE)

#Randomizing data
wine <-wineOriginal[sample(nrow(wineOriginal)),]

# Divide dataset for training and test
trainData <- wine[1:142, ]
testData  <- wine[143:178, ]

# Set predicted field in formula
formula = formula(Type ~ .)

# Create model for training set using naiveBayes
wineTrainingModel = naiveBayes(formula, trainData, threshold = 0)

# Display the predicted results and create cross table to check on accuracy
# Predict "Adjusted" column for test data set
wineTestPrediction <- predict(wineTrainingModel, testData)
# Display predicted values
wineTestPrediction

# Create cross table to check on accuracy.
CrossTable(wineTestPrediction, testData$Type,
           prop.chisq = FALSE, prop.t = FALSE, prop.r = FALSE,
           dnn = c('predicted', 'actual'))

# PMML generation
saveXML(pmml(wineTrainingModel, predictedField = "Type"), "Wine.pmml")

# The code below is used for evaluation purpose.
# The model is applied for original wine data set and predicted results are saved in "ROuput.csv"
# "ROuput.csv" file used for comparing the R results with PMML Evaluation engine results

# Applying Naive Bayes model to entire dataset and save the results in a CSV file
classes = predict(wineTrainingModel, newdata = wineOriginal, threshold = 0, type = "class")
probabilities = predict(wineTrainingModel, newdata = wineOriginal, threshold = 0, type = "raw")

# Save predicted value in a data frame
writeOutput = function(classes, probabilities, file){
	result = NULL
	if(is.null(probabilities)){
		result = data.frame(classes)
		names(result) = c("Type")
	} else
	{
		result = data.frame(classes, probabilities)
		names(result) = c("Type", "FirstClassWineProbability", "SecondClassWineProbability","ThirdClassWineProbability")
	}
	write.csv(result, file, quote=F)
}

# Write the results in a CSV file
writeOutput(classes, probabilities, "ROutput.csv")


library(dplyr)
library(GenomicRanges)
library(rtracklayer)
library(reshape2)
library(lattice)

read_matrix <- function(gr, cov, reverse_reads=FALSE) {
  if(class(cov) == "character") {
    cov <- import.bw(cov, which=gr, as="RleList")
  }

  transform_function <- if(reverse_reads) { rev } else { identity }
  o <- order(gr)
  gr <- gr[o]
  rl <- as(gr, "RangesList")
  view <- RleViewsList(rleList=cov[names(rl)], rangesList=rl)
  reads.list <- viewApply(view, function(x) { transform_function(as.numeric(x)) })
  reads.m <- matrix(unlist(sapply(reads.list, as.numeric)), nrow=length(gr), byrow=TRUE)
  reads.m[o, ] <- reads.m
  reads.m
}

standard_metapeak_matrix <- function(regions.gr, sample.cov, upstream=100, downstream=100) {

  regions.gr <- resize(regions.gr, width=downstream)
  regions.gr <- trim(resize(regions.gr, width=upstream + width(regions.gr), fix="end"))

  if(class(sample.cov) == "character") {
    stopifnot(file.exists(sample.cov))
    cov_seqlengths <- seqlengths(BigWigFile(sample.cov))
  } else {
    cov_seqlengths <- elementLengths(sample.cov)
  }

  if(anyNA(seqlengths(regions.gr))) {
    seqlengths(regions.gr) <- cov_seqlengths[seqlevels(regions.gr)]
  }

  remove_i <- which(width(regions.gr) != upstream + downstream)
  if(length(remove_i) > 0) {
    warning("Removing ", length(remove_i), " range(s() from `regions.gr` due to chromosome boundaries")
    regions.gr <- regions.gr[-remove_i]
  }

  stopifnot(length(regions.gr) > 0)
  stopifnot(length(unique(width(regions.gr))) == 1)

  reads <- matrix(nrow=length(regions.gr), ncol=width(regions.gr)[1])

  i_p <- which({strand(regions.gr) == "+" | strand(regions.gr) == "*"} %>% as.logical)
  i_n <- which({strand(regions.gr) == "-"} %>% as.logical)

  if(class(sample.cov) == "character") {
    sample.cov <- import.bw(sample.cov, which=regions.gr, as="RleList")
  }

  if(length(i_p) > 0) reads[i_p, ] <- read_matrix(regions.gr[i_p], sample.cov)
  if(length(i_n) > 0) reads[i_n, ] <- read_matrix(regions.gr[i_n], sample.cov, reverse_reads=TRUE)

  reads
}

standard_metapeak <- function(gr, sample.cov, upstream=100, downstream=100, sample_name=NA, smooth=NA) {

  reads <- standard_metapeak_matrix(gr, sample.cov, upstream, downstream)

  reads.df <- data.frame(stringsAsFactors=FALSE,
                         tss_distance=(-1 * upstream):(downstream - 1),
                         reads=colMeans(reads, na.rm=TRUE),
                         sample_name=sample_name)
  if(!is.na(smooth)) reads.df$reads <- as.numeric(runmean(Rle(reads.df$reads), k=smooth, endrule="constant"))
  reads.df
}

multisample_standard_metapeak <- function(grl, samples, upstream=100, downstream=100, smooth=NA, cores=1) {
  if(!is.list(grl)) grl <- list("Unnamed"=grl)

  names(samples) %>%
    mclapply(function(sample_name) {
      names(grl) %>%
      lapply(function(peak_group_name) {
          gr <- grl[[peak_group_name]]
          reads.df <- standard_metapeak(gr, samples[[sample_name]], upstream=upstream, downstream=downstream, smooth=smooth, sample_name=sample_name)
          reads.df$peak_group <- peak_group_name
          reads.df
      }) %>%
      bind_rows
    }, mc.cores=cores, mc.preschedule=FALSE) %>%
    bind_rows
}

enrichment_metapeak <- function(gr, sample.cov, bg.cov, upstream=100, downstream=100, sample_name=NA, smooth=NA) {

  reads.ip <- standard_metapeak_matrix(gr, sample.cov, upstream, downstream)
  reads.bg <- standard_metapeak_matrix(gr, bg.cov, upstream, downstream)

  ts.ip <- total_signal(sample.cov)
  ts.bg <- total_signal(bg.cov)

  reads.df <- data.frame(stringsAsFactors=FALSE,
                         tss_distance=(-1 * upstream):(downstream - 1),
                         reads=colMeans(reads.ip, na.rm=TRUE) / ts.ip,
                         background=colMeans(reads.bg, na.rm=TRUE) / ts.bg,
                         sample_name=sample_name)

  reads.df$enrichment <- reads.df$reads / reads.df$background

  if(!is.na(smooth)) {
    reads.df$reads      <- as.numeric(runmean(Rle(reads.df$reads), k=smooth, endrule="constant"))
    reads.df$background <- as.numeric(runmean(Rle(reads.df$background), k=smooth, endrule="constant"))
    reads.df$enrichment <- reads.df$reads / reads.df$background
  }

  reads.df
}

multisample_enrichment_metapeak <- function(grl, samples, upstream=100, downstream=100, smooth=NA, cores=1) {
  if(!is.list(grl)) grl <- list("Unnamed"=grl)

  names(samples) %>%
  mclapply(function(sample_name) {
    lapply(names(grl), function(peak_group_name) {
      gr <- grl[[peak_group_name]]
      reads.df <- enrichment_metapeak(gr, samples[[sample_name]]$ip, samples[[sample_name]]$wce,
                                      upstream=upstream, downstream=downstream, smooth=smooth, sample_name=sample_name)
      reads.df$peak_group <- peak_group_name
      reads.df
    }) %>%
    bind_rows
  }, mc.cores=cores, mc.preschedule=FALSE) %>%
  bind_rows
}

base_frequencies <- function(gr, upstream, downstream, genome=Dmelanogaster) {

  gr <- resize(gr, width=downstream)
  gr <- resize(gr, width=upstream + width(gr), fix="end")

  m <- consensusMatrix(getSeq(genome, gr))[1:4, ]
  m <- m / colSums(m)
  df.bases <- as.data.frame(t(m))
  df.bases$tss_distance <- (-1 * upstream):(downstream - 1)
  df.bases <- melt(df.bases, id.var="tss_distance")
  names(df.bases)[2:3] <- c("base", "frequency")
  df.bases
}


#!/usr/bin/env Rscript
options(stringAsfactors = FALSE, useFancyQuotes = FALSE)

# Taking the command line arguments
args <- commandArgs(trailingOnly = TRUE)

if(length(args)==0)stop("No file has been specified! Please select a file for performing grouping!\n")
require(xcms)
previousEnv<-NA
output<-NA
bw<-15
mzwid=0.005
for(arg in args)
{
  argCase<-strsplit(x = arg,split = "=")[[1]][1]
  value<-strsplit(x = arg,split = "=")[[1]][2]
  if(argCase=="input")
  {
    previousEnv=as.character(value)
  }
  if(argCase=="bandwidth")
  {
    bw=as.numeric(value)
  }
  if(argCase=="mzwid")
  {
    mzwid=as.numeric(value)
  }
  if(argCase=="output")
  {
    output=as.character(value)
  }

}
if(is.na(previousEnv) | is.na(output)) stop("Both input and output need to be specified!\n")

load(file = previousEnv)

toBeGrouped<-get(varNameForNextStep)

xcmsSetGrouped<-  group(toBeGrouped,bw=bw,mzwid=mzwid)

preprocessingSteps<-c(preprocessingSteps,"Group")

varNameForNextStep<-as.character("xcmsSetGrouped")

save(list = c("xcmsSetGrouped","preprocessingSteps","varNameForNextStep"),file = output)


library(Seurat)
source("R/functions/TestGeneSig.r")

fn = "data/H1_day0_scranNorm_adtbatchNorm_dist_clustered_TSNE_labels.rds"
h1 = readRDS(fn)

dn.out = "results"
dir.create(dn.out, showWarnings = F, recursive = T)

df.subj = h1@meta.data %>% dplyr::mutate(response = str_remove(adjmfc.time, "d0 ")) %>%
  dplyr::select(subject=sampleid, response) %>%
  dplyr::mutate(subject = factor(subject)) %>%
  distinct() %>%
  dplyr::arrange(subject)

# load signatures
sig.list = readRDS("sig/sig.list.RDS")

df.test = data.frame()

for(clustering in paste0("K",0:3)) {
  cat(clustering, "\n")
  h1 = SetAllIdent(h1, id = clustering)
  if(clustering != "K0") {
    cluster.names = h1@meta.data %>% pull(clustering) %>% unique() %>% sort()
  } else {
    cluster.names = "pseudo-bulk"
  }
  for(test.dir in c("IN")) {
    cat(test.dir, "\n")
    for (ccl.name in cluster.names) {
      if(clustering == "K0") {
        if(test.dir != "IN") next()
        tobj = h1
      } else {
        if(test.dir == "IN") {
          tobj = SubsetData(h1, ident.use=ccl.name)
        } else if(test.dir == "OUT") {
          tobj = SubsetData(h1, ident.remove=ccl.name)
        } else {
          stop("test.dir should be IN or OUT")
        }
      } # end if
      cat(ccl.name, " ")
      df.test = rbind(df.test,
                      TestGeneSig(tobj, sig.list, "sampleid", df.subj,
                                  "response", c("low","high"), test.to.print = NA) %>%
                        dplyr::mutate(cluster = ccl.name, test.dir, clustering)
      )
      cat("\n")
    } # ccl.name
  } # test.dir
} # clustering

fwrite(df.test, file.path(dn.out, "test_sig.genes_in_clusters_high_vs_low_responders.txt"), sep="\t")


scTIMo <- "MARTFFVGGNFKLNGSKQSIKEIVERLNTASIPENVEVVICPPATYLDYSVSLVKKPQVTVGAQNAYLKASGAFTGENSVDQIKDVGAKWVILGHSERRSYFHEDDKFIADKTKFALGQGVGVILCIGETLEEKKAGKTLDVVERQLNAVLEEVKDWTNVVVAYEPVWAIGTGLAATPEDAQDIHASIRKFLASKLGDKAASELRILYGGSANGSNAVTFKDKADVDGFLVGGASLKPEFVDIINSRN"
substr(scTIMo,152,155)
#"EEVK"
dTIMo <- "MARTPFVGGNWKMNGTKAEAKELVEALKAKLPDDVEVVVAPPAVYLDTAREALKGSKIKVAAQNCYKEAKGAFTGEISPEMLKDLGADYVILGHSERRHYFGETDELVAKKVAHALEHGLKVIACIGETLEEREAGKTEEVVFRQTKALLAGLGDEWKNVVIAYEPVWAIGTGKTATPEQAQEVHAFIRKWLAENVSAEVAESVRILYGGSVKPANAKELAAQPDIDGFLVGGASLKPEFLDIINSRN"
substr(dTIMo,152,155)
#"GLGD"

pos152 <- c()
pos153 <- c()
pos154 <- c()
pos155 <- c()
for (r in 1:nrow(aligned_proteins_wo_dscTIM)) {
  temp_string <- as.character(as.vector(aligned_proteins_wo_dscTIM[r,2]))
  residue <- substr(temp_string,152,152)
  if (residue != "-"){
    pos152 <- append(pos152,residue)
  }
  residue <- substr(temp_string,153,153)
  if (residue != "-"){
    pos153 <- append(pos153,residue)
  }
  residue <- substr(temp_string,154,154)
  if (residue != "-"){
    pos154 <- append(pos154,residue)
  }
  residue <- substr(temp_string,155,155)
  if (residue != "-"){
    pos155 <- append(pos155,residue)
  }
}

###################
#### pos152 #######
###################
#freq table
pos152_table <- table(pos152)
# %'s
pos152_table_prop <- prop.table(pos152_table)
pos152_table_prop["G"]
# 16%
max(pos152_table_prop)
# 22%  - S
pos152_table_prop["E"]
# 3%

write.csv(pos152_table_prop,file="/Users/mercicle/Documents/python_workspace/BioVis/Codes/ProcessBook/pos152_table_prop.csv")

###################
#### pos153 #######
###################
#freq table
pos153_table <- table(pos153)
# %'s
pos153_table_prop <- prop.table(pos153_table)
pos153_table_prop["L"] #dTIM has an L
# 7%
max(pos153_table_prop)
# 62%  - I
pos153_table_prop["E"]
# None
write.csv(pos153_table_prop,file="/Users/mercicle/Documents/python_workspace/BioVis/Codes/ProcessBook/pos153_table_prop.csv")


## functions for extracting date/time info

## make function to extract multi-day indication, accounting for Daily entry, bridging all values in between
weekday_calc <- function(entry_val) {
  # browser()
  weekday_lookup <- data.frame(weekday = c("Monday", "Tuesday", "Wednesday", "Thursday",
                                           "Friday", "Saturday", "Sunday"),
                               abbrev = c("Mon", "Tues", "Wed", "Thurs", "Fri", "Sat", "Sun")) %>%
    mutate(ord = 1:n(), abbrev = as.character(abbrev)) ## abbrev doesn't need to be factor, only weekday for seq below

  ## check for /
  check_special <- str_detect(entry_val, "/")

  res <- str_extract_all(entry_val, "[:alpha:]*")[[1]] %>%
    tbl_df() %>%
    dplyr::rename(weekday = value) %>%
    filter(str_detect(weekday, "Daily|Mon*|Tues*|Wed*|Thurs*|Fri*|Sat*|Sun*")) ## define character class, will require testing

  ## trim s at end
  res$weekday <- str_remove(res$weekday, "s$")

  ## handle Daily
  if(str_detect(res$weekday, "Daily") %>% any) {
    res <- weekday_lookup %>% mutate(weekday = as.character(weekday))
  }

  ## handle day abbreviations
  else if(!str_detect(res$weekday, "day") %>% any) {
    res <- res %>% select(abbrev = weekday) %>% left_join(weekday_lookup, by = "abbrev") %>% select(-abbrev)
  }

  ## handle multi-days, fill in
  if(length(res$weekday) > 1) {

   if(!check_special) {
      ## fill in the gap of remaining days
      res <- seq(weekday_lookup$ord[weekday_lookup$weekday == res$weekday[1]],
                 weekday_lookup$ord[weekday_lookup$weekday == res$weekday[length(res$weekday)]], by = 1)
      res <- data.frame(ord = res) %>% left_join(weekday_lookup %>% select(-abbrev), by = "ord")
      res <- res %>% mutate(weekday = as.character(weekday))
    }

  }

  return(res)
}

## function to extract open time
time_calc <- function(entry_val) { ## add robustness to confirm time 1 is min, time 2 is max
  open_time <- str_extract_all(entry_val, "[:digit:]{1,2}:[:digit:]{2} [:alpha:]{2}")[[1]][1]
  close_time <- str_extract_all(entry_val, "[:digit:]{1,2}:[:digit:]{2} [:alpha:]{2}")[[1]][2]

  return(list(open_time = open_time, close_time = close_time))
}

## function to extract months, and add day of month** verify this method, example had specific day
season_calc <- function(entry_val) {
  # browser()
  date_from = str_split(entry_val, "[:punct:]")[[1]][1]
  # date_from = lubridate::make_date(year = lubridate::year(Sys.time()), month = date_from, day = 1)

  date_to = str_split(entry_val, "[:punct:]")[[1]][2]
  # date_to = lubridate::make_date(year = lubridate::year(Sys.time()), month = date_to, day = 1)

  return(list(date_from = date_from, date_to = date_to))
}

# season_calc(agh_farm_markets$Season[1])


#' knots2mph
#'
#' Conversion from knots per second to miles per hour.
#'
#' @param knots numeric  Speed in knots per second.
#' @return miles per hour
#'
#'
#' @author    Istituto per la Bioeconomia CNR Firenze Italy  Alfonso Crisci \email{alfonso.crisci@@ibe.cnr.it}
#' @keywords  knots2mph
#'
#' @export
#'
#'
#'
#'

knots2mph=function(knots) {
                         ct$assign("knots", as.array(knots))
                         ct$eval("var res=[]; for(var i=0, len=knots.length; i < len; i++){ res[i]=knots2mph(knots[i])};")
                          res=ct$get("res")
                         return(ifelse(res==9999,NA,res))
}


library(zoo)

# Function to take the first two cols of data and convert to one Date/Time
f <- function(d, t) as.chron(paste(as.Date(chron(d, format='d:m:y')), t))

# Takes aeronet data and returns a zoo class.
import_aeronet_data <- function(filename)
{
  colClasses <- c("character", "character", rep("NULL", 10), "numeric", rep("NULL",6), "numeric", rep("NULL",25))
  r = read.zoo(filename, sep=',', na.strings = "N/A", header=T, skip=4, index = 1:2, FUN=f, colClasses=colClasses, as.is=F, dec=".")
  names(r) <- c("AOT", "PWC")

  # Warning: this conversion was added to fix problems
  # with the output format of start(aeronet) for use in
  # AERONET-Radiosonde comparison
  # Remove if it causes problems with BIGF validation
  index(r) <- as.POSIXct(index(r))

  return(r)
}


#' ms2knots
#'
#' Conversion speed meter per second in knots per second.
#'
#' @param ms Speed numeric   in meters per second [m/s].
#' @return  knots per second
#'
#'
#' @author Istituto per la Bioeconomia CNR Firenze Italy  Alfonso Crisci \email{alfonso.crisci@@ibe.cnr.it}
#' @keywords  ms2knots
#'
#' @export
#'
#'
#'
#'

ms2knots=function(ms) {
                         ct$assign("ms", as.array(ms))
                         ct$eval("var res=[]; for(var i=0, len=ms.length; i < len; i++){ res[i]=ms2knots(ms[i])};")
                        res=ct$get("res")
                         return(ifelse(res==9999,NA,res))
}


    library(ggtree)
    library(treeio)

    treetext = "(((ADH2:0.1[&&NHX:S=human], ADH1:0.11[&&NHX:S=human]):
    0.05 [&&NHX:S=primates:D=Y:B=100],ADHY:
    0.1[&&NHX:S=nematode],ADHX:0.12 [&&NHX:S=insect]):
    0.1[&&NHX:S=metazoa:D=N],(ADH4:0.09[&&NHX:S=yeast],
    ADH3:0.13[&&NHX:S=yeast], ADH2:0.12[&&NHX:S=yeast],
    ADH1:0.11[&&NHX:S=yeast]):0.1[&&NHX:S=Fungi])[&&NHX:D=N];"

    tree <- read.nhx(textConnection(treetext))

    ggtree <- ggtree(tree) + geom_tiplab() +
        geom_label(aes(x=branch, label=S), fill='lightgreen') +
        geom_label(aes(label=D), fill='steelblue') +
        geom_text(aes(label=B), hjust=-.5)

    if(interactive()) {
        # Interactive example
        print(ggtree)
    } else {
        # Run when used from command line
        ggsave("tree.png")
    }


# Creates a heatmap to display differentiated kegg pathways, with additional color bars at the top
# NOTE: uses pearson's correlation as distance function due to inherent limitations with Bray-Curtis
# -------------
# Contributor: PJ
# -------------
# Input:
#         otu: normalized and filtered otu table
#         map: mapping table that has already been subsetted to include samples of interest
# cluster.var: vector of column names to cluster samples by (e.g. can be a single column for
#              simple heatmaps, such as Treatment)
#   color.var: vector of column names, color bars added to top of heatmap (suggested usage:
#              set color.var=cluster.var) note that factors will be treated as distinct colors,
#              and numerics will be transformed into gradients
#  color.list: list of color vectors, one vector per color.var to specify the colors used
# kegg_pathways: vector of pathways, useful for highlighting different levels
# heatmap.title: title to display on the heatmap
# -------------
# Output:
#   outputfile: heatmap output file name
# -------------
# Last update:10/29/2014
#

# hclusts the columns of an OTU table according to groupings of samples
cluster.columns<-function(otu, distfun, new.treatments)
{
	col.labels <- NULL
	# separate samples by unique values of new.treatments that we're interested in clustering by
	unique.new.treatments <- levels(new.treatments)
	for(i in 1:length(unique.new.treatments)){
		otu.by.clustergroup <- otu[new.treatments==unique.new.treatments[i], ]
		data.dist.group <- distfun(otu.by.clustergroup)
		col.clus.group <- hclust(data.dist.group)
		d <- as.dendrogram(col.clus.group)
		# since the index order is per group only, we'll have to add the current length each time
		# to get correct indices along the combined dendrogram
		col.labels <- c(col.labels, labels(d))
	}

	col.labels
}
# hclusts the rows
cluster.rows<-function(otu, distfun)
{
	# do the row-clustering (note that we need to explicitly reorder the dendrogram here)
	Rowv <- rowMeans(otu)
	hcr <- hclust(distfun(otu))
	ddr <- as.dendrogram(hcr)
	ddr <- reorder(ddr, Rowv)
	rowInd <- order.dendrogram(ddr)
#		row.labels <- labels(ddr)[rowInd] #THIS IS CRITICAL?
	row.labels <- labels(ddr)
#print(labels(ddr)[rowInd])

	list(ddr=ddr, row.labels=row.labels)
}

#"shorten.taxonomy" <- function(ids,delim=';'){
#	ids <- gsub('[kpcofgs]__','',ids)
#	newids <- ids
#	ids <- strsplit(ids,delim)
#	for(i in seq_along(ids)){
#		n <- length(ids[[i]])
#		j <- n
#		while(ids[[i]][j] == 'Other' || ids[[i]][j] == '') j <- j - 1
#		newids[i] <- ids[[i]][j]
#	}
# 	return(newids)
#}

# map: rows must have already been reorder by the hclust
# color.list: list of named vectors that have been named according to color.var values
create.color.bars<-function(map, color.var, color.list)
{
	col.colors <- NULL
	for(i in 1:length(color.var))
	{
		reordered <- map[,color.var[i]]
		if(is.numeric(reordered)){
			color.palette <- colorRampPalette(color.list[[color.var[i]]])
			num.breaks <- 20 #? for gradients
			colors <- color.palette(num.breaks)[as.numeric(cut(reordered,breaks = num.breaks))]
		} else {
				colors <- unname(color.list[[color.var[i]]][as.character(reordered)])
		}
		col.colors <- cbind(col.colors, colors)
	}
	colnames(col.colors) <- color.var
	col.colors

}

# helper function for reading in color.list file into a named list of named vectors
"read.color.list" <- function(filename)
{
	x <- scan(filename, what="", sep="\n",quiet=T, comment.char="#")
	# Separate elements by tab
	y <- strsplit(x, "\t")

	# Collapse vectors into named vectors
	for(i in seq(2, length(y), 2))
	{
		names(y[[i]]) <- y[[i-1]]
	}
	# remove odd list items (names)
	z <- y[-(seq(1, length(y), 2))]

	# Extract the first vector element and set it as the list element name
	names(z) <- sapply(z, function(x) x[[1]])
	# Remove the first vector element from each list element
	z <- lapply(z, function(x) x[-1])
	return(z)
}

# combines cluster variable values to create new groupings to cluster by
create.new.treatments<-function(map, cluster.var)
{
	if(length(cluster.var) > 1){
		new.treatments <- as.factor(apply(map[,cluster.var], 1, paste0, collapse="."))
	} else {
		new.treatments <- map[,cluster.var]
		# cluster.var must be a factor in order to cluster properly, apply original levels
		new.treatments <- as.factor(new.treatments)
		levels(new.treatments) <- names(color.list[[cluster.var]])
	}
	names(new.treatments) <- rownames(map)
	new.treatments
}

# Creates a heatmap to display differentiated kegg pathways, with additional color bars at the top
# NOTE: uses pearson's correlation as distance function due to inherent limitations with Bray-Curtis
#
# otu: normalized and filtered otu table
# map: mapping table that has already been subsetted to include samples of interest
# see ../config for files containing clustering and color variables
# cluster.var: vector of column names to cluster samples by (e.g. can be a single column for simple heatmaps, such as Treatment)
# color.var: vector of column names, color bars added to top of heatmap (suggested usage: set color.var=cluster.var)
#			note that factors will be treated as distinct colors, and numerics will be transformed into gradients
# color.list: list of color vectors, one vector per color.var to specify the colors used
# kegg_pathways: vector of pathways, useful for highlighting different levels
# heatmap.title: title to display on the heatmap
# outputfile: heatmap output file name
heatmap.mwas <- function(otu, map, diff.features, kegg_pathways, heatmap.title="", outputfile)
#TODO add some extra formatting parameters here
# OPTIONAL: distance matrix
{
	source("heatmap.3.r")
    #source("util.r")

    #require(vegan)
    #require(RColorBrewer)
    #require(gplots)

	cluster.var.fn <- parse.params("heatmap.mwas", "cluster.var")
	color.list.fn <- parse.params("heatmap.mwas", "color.list")
	cluster.var <- read.table(cluster.var.fn) # vector
	color.list <- read.color.list(color.list.fn)
	color.var=names(color.list)

	use.kegg <- as.logical(length(kegg_pathways))

	otu <- otu[,diff.features]

	# use pearson's correlation for the distance function (bray-curtis has scaling issues)
	distfun <- function(x) as.dist((1-cor(t(x)))/2)

	# do row and column clustering
	col.labels <- cluster.columns(otu=otu, distfun=distfun, new.treatments=new.treatments)
	ret <- cluster.rows(otu=as.matrix(t(otu))[,col.labels], distfun=distfun)
	row.dendrogram <- ret$ddr
	row.labels <- ret$row.labels

	# create each of the colored bars, reorder to previous column clustering
	col.colors <- create.color.bars(map[col.labels,], color.var, color.list)

	# color row axis labels according to KEGG
	kegg.colors <- NULL
	if(use.kegg)
	{
		# TODO add more colors here
		axis.colors <- c("orange","firebrick3","aquamarine3","steelblue3","black", "mediumpurple3")
		kegg <- kegg_pathways[row.labels]
		lookup <- axis.colors[1:length(unique(kegg))]
		names(lookup) <- sort(unique(kegg))
		# diabetes only!
		#lookup["Metabolism of Other Amino Acids"] <- lookup["Amino Acid Metabolism"]
		kegg.colors <- lookup[as.character(kegg)]
		names(kegg.colors) <- names(kegg) #change these names so it's easier to reference later
	}

	# do all formatting here
	## consider redrawing on a really large PDF - extra spacing is okay
	## allow for max cap on # of features --> set this from the command line (with disclaimer)

	lwid = c(1.9,9,4) #col widths
	lhei = c(1.1,.3+.1*length(color.var),7.1,1.6) #row heights
	lmat = rbind(c(3,4,0), c(0,1,0), c(0,2,0), c(0,5,0))
	margins=c(4,6)
	legend1.x=.601 #color bar legend
	legend1.y=1.011
	width=7 #pdf size
	height=7
	hm.colors <- colorRampPalette(c("blue","black","yellow"))(27)
	main <- heatmap.title

	if(!use.kegg) #update some params if showing only taxa
	{
		lhei = c(.7,.3,8,1) #row heights
		margins=c(.1,.1)
		legend1.x=.735
		legend1.y=1
		width=10
		height=12
	}

	# standardize each feature so it stands out more
	otu <- apply(otu, 2, function(x) (x-mean(x))/sd(x))

	# make the heatmap
	pdf(file=outputfile, width=width, height=height)

	otu.for.heatmap <- as.matrix(t(otu))
	if(!use.kegg){
		rownames(otu.for.heatmap) <- shorten.taxonomy(rownames(otu.for.heatmap))
	}

	heatmap.3(otu.for.heatmap[,col.labels], Rowv = row.dendrogram, Colv = NA, dendrogram='none',
	col = hm.colors, ColSideColors = col.colors, trace = "none", density.info = "none", rowAxisColors=kegg.colors,
	main = main, key=TRUE, keysize=5, lmat=lmat, lwid=lwid, lhei=lhei, labCol=NA,
	margins=margins,cexCol=.7, scale="none"
	)

	# add the legend for the colored bars
	legend(x=legend1.x, y=legend1.y,legend=unname(unlist(lapply(color.list, names))),
	fill=unlist(color.list),border=FALSE, bty="n", y.intersp = 0.8, cex=0.7, ncol=3, text.width=c(0, .04, .06 ) )#
																						#= strwidth("1,000")
	if(use.kegg) # add the legend for the row axis colors
	{
		legend(x=.59, y=.12,legend=names(lookup),
		fill=lookup, border=FALSE, bty="n", y.intersp = 0.8, cex=0.7, text.col="dimgray")
	}

	dev.off()

}


#!/usr/bin/env Rscript
###
### Perform simple forward model selection, always choosing to add the
### variant that increases adjusted R2 by the greatest amount (or
### decreases adj. R2 by the least).
###
### Imputes missing genotype data by using the mean; ignores strains with
### missing phenotype data.
###

library(data.table)
library(MASS)

argv = commandArgs(trailingOnly=TRUE)
genotype_file = argv[1]
phenotype_file = argv[2]
variant_file = argv[3]
n_vars = as.numeric(argv[4])
min_maf = as.numeric(argv[5])
output_prefix = argv[6]

oh = file(paste0(output_prefix, '.stats.tsv'), 'wb')
ohf = file(paste0(output_prefix, '.fitted.tsv'), 'wb')

n_random_vars = 10000

genotypes = fread(genotype_file, header=TRUE)
setkey(genotypes, 'rs')
phenotypes = fread(phenotype_file)
variants = scan(variant_file, what='character')

## Filter by MAF
maf = apply(genotypes[, -(1:3)], 1,
            function(x) min(sum(x == 0, na.rm=TRUE), sum(x == 1, na.rm=TRUE))/sum(!is.na(x)))
genotypes = genotypes[maf >= min_maf, ]
cat(nrow(genotypes), 'variants left after MAF filtering\n', file=stderr())

if(length(variants) < n_vars) {
    stop("Can't choose that many variants")
}

## Sort genotype data by the order in variant_file and
## impute missing genotype data.
X = apply(t(as.matrix(genotypes[variants, -(1:3)])), 2,
          function(x) { x[is.na(x)] = mean(x, na.rm=TRUE); x})
p = phenotypes[match(rownames(X), as.character(phenotypes[[ 2]])), ]
y = p[[3]]

## Choose random variants for calculating LD
X_rand = t(as.matrix(genotypes[sample(1:nrow(genotypes), n_random_vars, FALSE), -(1:3)]))

## Print output file headers
cat('n_vars_start\tr2\tr2_unadj\tr2_resid\tgenomic_r2\tgenomic_r2_unadj\tn_vars_final\t',
    'ranks_final\tvars_final\tcoefficients\n',
    file=oh, sep='')
cat('n_vars_start\tphenotype\tfitted\n', file=ohf)

### Run the model selection
vars_included = character(n_vars)
XX = as.matrix(X[, 1:n_vars]) # Genotype data with just the top n_vars variants
colnames(XX) = paste0('XX', 1:n_vars)
XX = as.matrix(XX[, !is.na(apply(XX, 2, mean))])
for(nv in 1:n_vars) {

    ## Figure out which variant gives the greatest R2
    max_r2a = -Inf
    current_var = ''
    for(i in 1:n_vars) {
        test_var_name = paste0('XX', i)
        if(test_var_name %in% vars_included) {
            next
        }
        vars_in_this_model = c(vars_included[vars_included != ''],
                               test_var_name)
        XXX = XX[, vars_in_this_model, drop=FALSE]
        if(ncol(XXX) == 0) {
            next
        }
        model = lm(y ~ XXX)
        r2a_this_variant = summary(model)$adj.r.squared
        if(r2a_this_variant > max_r2a) {
            current_var = test_var_name
            max_r2a = r2a_this_variant
        }
    }

    ## If nothing found
    if(current_var == '') {
        break
    }

    ## Get the stats for the best model
    vars_included[nv] = current_var
    vars_in_this_model = vars_included[vars_included != '']
    XXX = XX[, vars_in_this_model]
    model = lm(y ~ XXX)
    s = summary(model)
    r2 = s$r.squared
    r2a = s$adj.r.squared
    rhs_final = as.character(model$call$formula)[3]
    ranks_final = as.numeric(gsub('XXXXX', '',
                                  names(model$coefficients)[-1]))

    ## Measure the R2 on the residuals from the previous model
    if(nv > 1) {
        previous_vars_model = vars_in_this_model[1:(nv-1)]
        pv = XX[, previous_vars_model]
        rs = residuals(lm(y ~ pv))
        cv = XX[!is.na(y), current_var]
        model2 = lm(rs ~ cv)
        r2_resid = summary(model2)$adj.r.squared
    } else {
        r2_resid = r2a
    }

    coefs_final = model$coefficients
    variants_final = variants[ranks_final]
    ft = model$fitted.values

    ## LD between variants included in the model and other variants
    ## measured using a randomly selected subset to reduce run time.
    gr2 = 0
    gr2c = 0
    gr2a = 0
    gr2ac = 0
    for(i in 1:n_random_vars) {
        ss = summary(lm(paste('X_rand[, i] ~', rhs_final)))
        if(!is.na(ss$r.squared)) {
            gr2 = gr2 + ss$r.squared
            gr2c = gr2c + 1
        }
        if(!is.na(ss$adj.r.squared)) {
            gr2a = gr2a + ss$adj.r.squared
            gr2ac = gr2ac + 1
        }
    }

    cat(nv, '\t', round(r2a, 3), '\t', round(r2, 3),
        '\t', round(r2_resid, 3),
        '\t', round(gr2a/gr2ac, 3), '\t', round(gr2/gr2c, 3),
        '\t', length(variants_final),
        '\t', paste(ranks_final, collapse=','),
        '\t', paste(variants_final, collapse=','),
        '\t', paste(coefs_final, collapse=','),
        '\n', sep='', file=oh)
    write.table(cbind(rep(nv, sum(!is.na(y))), y[!is.na(y)], ft),
                col.names=FALSE, row.names=FALSE, quote=FALSE,
                sep='\t', file=ohf)
    flush(oh)
    flush(ohf)
}

close(oh)
close(ohf)


################################################################################
# Dependencies
# library("BayesTree")

BartTrain <- function(train.name="train",target=NULL,args=list(test.name=NULL,R=1,
	pls=FALSE,prune=FALSE,std=FALSE,features=c("static","alsfrs","fvc","svc",
	"vital"), slope.features=NULL)) {
	# Trains a Bayes Tree regression model to given training data and returns a
	# function that returns predictions given test data
	#
	# Args:
	#	train.name: base name of training dataset
	#	target: target vector; if NULL, future slopes are used as target
	#	args: list of additional arguments
	#	-test.name: base name of test set, if you want training set to be
	#	 processed using both test and train data
	#   - R: number of models to train; final predictions formed
	#        by averaging across model predictions
	#	- pls: TRUE means predicting the last score rather than the slope
	#	- prune: TRUE means keeping only features with data for at least 918/2
	#		patients
	#	- std: TRUE means standardize columns by subtracting away column means
	#	- features: a character vector of feature sets to get for the training
	#		data.  Choose from "static","alsfrs","fvc","svc","vital","lab"
	#	- slope.features: a character vector of datasets to get slope features
	#		for.  Choose from NULL if no slopes are desired, or among "static",
	#		"alsfrs","fvc","svc","vital","lab"
	#
	#
	# Returns:
	#	A function that returns predictions given test data
	#
	# Example usage:
	if (FALSE) {
	   	train.name="traintest"
	   	test.name="validation"
		features = c("static","alsfrs","fvc","svc","vital")
	   	slope.features = c("alsfrs","fvc","svc","vital")
	   	args=list(test.name=test.name, R=10,pls=FALSE,prune=FALSE,std=FALSE,
	   		features=features,slope.features=slope.features)
		model <- BartTrain(train.name=train.name,target=NULL,args=args)
		predictions<-model(test.name=test.name)
	}

	# Preprocess training data according to arguments
	train.preprocess<-PreprocessFeatures(train.name=train.name,
		test.name=args[["test.name"]],args=args)

	# Get training data and target
	train.data<-train.preprocess$feature.data

	target<-train.preprocess$target

	# Drop constant columns
	train.data<-train.data[,apply(train.data,2,function(c)length(unique(c))>1)]

	BartPredict <- function(test.name="test",save.preds=TRUE) {
		# Predicts slopes using a LASSO regression fit to static training data.
		#
		# Args:
		#	test.name: base name of test set
		#   save.preds: save predictions to file? TRUE by default
		#
		# Returns:
		#	Two column matrix, ordered by the first column, with first column
		#   "subject.id" containing test set subject ids and the second column
		#   "prediction" containing predicted slopes.
		#
		# Side effects:
		#	Saves predictions to file

		# Preprocess test data according to arguments
		test.preprocess<-PreprocessFeatures(train.name=NULL,test.name=test.name,
			args=args,train.cols=train.preprocess$train.cols,train.data.std=
			train.preprocess$train.data.std,
			train.data.na=train.preprocess$train.data.na)

		test.data<-test.preprocess$feature.data

		# Match train columns
		test.data<-test.data[,colnames(train.data)]

		# Obtain test predictions from R BART models
		predictions<- matrix(sapply(1:args[["R"]],
			function(i) { object<-bart(x.train=train.data[,-1],y.train=target,
			x.test=test.data[,-1],ntree=100,keeptrainfits=FALSE,printevery=1000,
			ndpost=10000,sigquant=0.5); return(object$yhat.test.mean) }),ncol=args[["R"]])

		# Compute average model prediction
		predictions <- rowMeans(predictions)
		# If predicting last score, transform predictions back to slopes
		if (args[["pls"]]) {
			scaling<-PlsScale(test.name)
			predictions<-predictions-
				scaling$score.first*scaling$time.scale
		}
		predictions <- cbind(test.data[,1],predictions)

		if(save.preds) {
			# Write predictions to file
			out.file = GetPredictionFilename("BartTrain",train.name,test.name,args)
			WritePredictions(predictions, out.file)
		}

		return(predictions)
	}

	return(BartPredict)
}


cepath="C:/Users/stu/Desktop/exam"
if(getwd()!=cepath)setwd(cepath)
# -------------1-----------------------
#temp=read.csv2(file = "metadata.csv",header=TRUE,seq="\t")
pattern_str_C="Control Neurones"
pattern_str_D="Diabetic Neurones"
library(stringr)
judge_Cneu=!is.na(str_extract(pattern = pattern_str_C,metadata$Sample_organism))
judge_Dneu=!is.na(str_extract(pattern = pattern_str_D,metadata$Sample_organism))
C_sample_names=metadata$Sample_status[judge_Cneu]
D_sample_names=metadata$Sample_status[judge_Dneu]
C_sample=genematrix[C_sample_names]
D_sample=genematrix[D_sample_names]
T1_result=rbind(D_sample,C_sample)
rownames(T1_result)=genematrix$ENSEMBL
save(T1_result,file="C_D.csv")
# -------------2-----------------------
C_avg=apply(C_sample,1,mean)
D_avg=apply(D_sample,1,mean)
Fold_change=D_avg/C_avg
p_list=c()
for(i in 1:nrow(C_sample)){
  p_list=append(p_list,t.test(C_sample[i,],D_sample[i,],var.equal=TRUE)$p.value)
}
T2_result=data.frame('Control_avg'=C_avg,'Diabetes_avg'=D_avg,'Fold_change'=Fold_change,'p_list'=p_list)
rownames(T2_result)=genematrix$ENSEMBL
save(T2_result,file="T2_result.csv")
# -------------3-----------------------
symbol_ID=bitr(genematrix$ENSEMBL,fromType = "ENSEMBL",toType = "SYMBOL",
               OrgDb = org.Hs.eg.db,drop=FALSE)
T2_result$SYMBOL=symbol_ID$SYMBOL
# -------------4-----------------------
T2_result$Fold_change=log2(T2_result$Fold_change)
library(ggplot2)
cut_off_pvalue = 0.05
cut_off_logFC = log2(1/1.2)
# get meaningful expressions
T2_result$change = ifelse(T2_result$p_list < cut_off_pvalue & abs(T2_result$Fold_change) >= cut_off_logFC,
                        ifelse(T2_result$Fold_change> -cut_off_logFC ,'Up',
                               ifelse(T2_result$Fold_change < cut_off_logFC,'Down','Stable')),
                        'Stable')

# annotate gene labels
T2_result$delabel <- NA
library(stringr)
library(ggrepel)
for (i in 1:nrow(T2_result)){
  if(T2_result$Fold_change[i]!="Stable"){
    T2_result$delabel[i] =
      str_extract_all(T2_result$SYMBOL[i],"([A-Z0-9]+)")[[1]][1]
  }
}

# draw volcano graph
p=ggplot(
  data=T2_result, aes(x=Fold_change, y=-log10(p_list),col=change)) +
  geom_point(alpha=0.4, size=2.5) +
  # set color
  scale_color_manual(values=c("blue", "grey","red"))+
  theme_minimal()+
  # add annotation
  geom_label_repel(
    data = subset(T2_result, T2_result$p_list < 0.05 & abs(T2_result$Fold_change) >= cut_off_logFC),
    aes(label = delabel),
    size = 4,
    box.padding = unit(0.35, "lines"),
    point.padding = unit(0.3, "lines"))+
  # draw lines
  geom_vline(xintercept=c(-cut_off_logFC, cut_off_logFC),lty=4, col="grey",lwd=0.8) +
  geom_hline(yintercept=-log10(cut_off_pvalue),lty=4, col="grey",lwd=0.8)+
  # draw labels
  labs(x="log2(fold change)",
       y="-log10(p-value)")+
  theme_bw()+
  theme(plot.title = element_text(hjust = 0.5),
        legend.position="right",
        legend.title = element_blank())
# save file
ggsave(p,filename = 'result.jpg',dpi = 300, width = 12,height = 9)
# -------------5-----------------------
dif_gene=T2_result$SYMBOL[T2_result$change!="Stable"]
if(!requireNamespace("clusterProfiler",quietly = TRUE))
  install.packages("clusterProfiler")#this might be slow to be loaded
library(clusterProfiler)
if(!requireNamespace("org.Hs.eg.db",quietly = TRUE))
  BiocManager::install("org.Hs.eg.db")#this might be slow to be loaded
library(org.Hs.eg.db)

ego=enrichGO(gene = dif_gene,
             OrgDb='org.Hs.eg.db',
             keyType = "SYMBOL",
             ont = 'BP',
             universe=T2_result$SYMBOL,
             pvalueCutoff = 1,
             pAdjustMethod = "none",
             minGSSize = 10,
             maxGSSize = 20,
             readable = FALSE)#此处有bug，true会报错，需要反馈给clusterProfiler开发者
if(!requireNamespace("GOplot",quietly = TRUE))
  install.packages("GOplot")
library(GOplot)
if(!requireNamespace("enrichplot",quietly = TRUE))
  install.packages("enrichplot")
library(enrichplot)
library(DOSE)
library(ggnewscale)
# draw fancy graphs that I can't depict if I did it again
g1=dotplot(ego,showCategory=30)
ggsave(g1,filename = "dotplot.png",dpi = 600, width = 12,height = 9)
g2=heatplot(ego)# no fold change here or generate randomly
ggsave(g2,filename = "heatplot.png",dpi = 600, width = 12,height = 9)
g3=cnetplot(ego,categorySize="pvalue",circular = TRUE, colorEdge = TRUE)
ggsave(g2,filename = "cneplot.png",dpi = 600, width = 12,height = 9)
g4=emapplot(ego)
# cut redundancy
ego2=simplify(ego,cutoff=0.7,by="p.adjust",select_fun=min)


source("test-dmrff.r", echo=T)
source("test-meta.r", echo=T)


  #Pesquisa realizada na base de dados do PNADc IBGE
  #Buscou-se identificar a média de Renda vs Escolaridade dos setores:
  #Privado, público, conta-própia, empregador, familiar auxiliar e trabalhador doméstico.

#### Carregando o banco de dados ####

# Passo 1: selecionar o diretório de trabalho (working directory)
## Session > Set Working Directory > Choose Directory

setwd("C:/Users/User/Desktop/PNADc")

#### Instalando e carregando as bibliotecas ####

#PNADcIBGE: Responsável por trazer a base de dados

if(!require(PNADcIBGE))
  install.packages("PNADcIBGE ")
library(PNADcIBGE)

#psych: Fornecer os valores:
  #média, mediana, quartis e valores mín e máx

if(!require(psych))
  install.packages("psych")
library(psych)

#dplyr: Agrupar os valores criados

if(!require(dplyr))
  install.packages("dplyr")
library(dplyr)

#esquisse: Auxilia na exploração e extração das informações

if(!require(esquisse))
  install.packages("esquisse")
library(esquisse)

#ggplot2: Plotar as informações

if(!require(ggplot2))
  install.packages("ggplot2")
library(ggplot2)

#### Tratando os dados ####

#Extraindo as variáveis da base de dados (PNADcIBGE)

dadosPNADc <- get_pnadc(year = 2020, quarter = 4, vars=c("VD4008","VD4020","V3009A"))

#Filtrar as variáveis importadas

varPNADc<- dadosPNADc$variables

#Eliminar colnas desnecessárias

varPNADc <- subset(varPNADc, select = -c(Ano, Trimestre, UPA, Estrato, V1008, V1027, V1029, posest, V2003, Habitual, Efetivo))

#Eliminar os valores NA

varPNADc2 <- na.omit(varPNADc)

#Renomear colunas (dplyr)

varPNADc2 <- rename(varPNADc2, Escolaridade = V3009A, Setor = VD4008, Renda = VD4020)

#Cria um novo arquivo CSV apenas com um uma variavel escolhida dentro do setor

write.csv2(subset(varPNADc2, Setor == "Empregado no setor privado"), "Empregado no setor privado.csv",  row.names = FALSE)
write.csv2(subset(varPNADc2, Setor == "Empregado no setor público (inclusive servidor estatutário e militar)"), "Empregado no setor público.csv",  row.names = FALSE)
write.csv2(subset(varPNADc2, Setor == "Trabalhador familiar auxiliar"), "Empregado no setor privado.csv",  row.names = FALSE)
write.csv2(subset(varPNADc2, Setor == "Conta-própria"), "Conta-própria.csv",  row.names = FALSE)
write.csv2(subset(varPNADc2, Setor == "Empregador"), "Empregador.csv",  row.names = FALSE)
write.csv2(subset(varPNADc2, Setor == "Trabalhador doméstico"), "Trabalhador doméstico.csv",  row.names = FALSE)

#Importa o arquivo CSV criado

privado <- read.csv2('Empregado no setor privado.csv', stringsAsFactors = T)
publico <- read.csv2('Empregado no setor público.csv', stringsAsFactors = T)
familiar <- read.csv2('Trabalhador familiar auxiliar.csv', stringsAsFactors = T)
propia <- read.csv2('Conta-própria.csv', stringsAsFactors = T)
empregador <- read.csv2('Empregador.csv', stringsAsFactors = T)
domestico <- read.csv2('Trabalhador doméstico.csv', stringsAsFactors = T)

#Explorar e gerar os gráficos

esquisser(privado)
esquisser(publico)
esquisser(familiar)
esquisser(propia)
esquisser(empregador)
esquisser(domestico)

#Exemplo de gráfico "Setor Público - Escolaridade vs Renda"

library(ggplot2)

ggplot(publico) +
  aes(x = Renda, y = Escolaridade) +
  geom_boxplot(shape = "circle", fill = "#112446") +
  labs(x = "Renda", y = "Escolaridade", title = "Setor Público", subtitle = "Escolaridade vs Renda") +
  theme_minimal()

#Fim


#The simulation script includes three aims.
#when pi=0, to estimate the utility of detecting invers-axis in cases only.
#when pi!=0, to estimate the power of detecting invers-axis in cases only.
#simulations to compare the OR of disease risk between LEV and cSEV-PB

#disease risk model setting
#LTM (liability threshold model)
#logit model

#genetric architecture setting
# a=Infinitesimal architecture
# b=with negative selection
# c=LD-adjusted kinship

args=commandArgs(TRUE)  #subjob id
subjob_id=as.numeric(args[1]) #subjob id

N_simulation=500  #simulation times

#subjobs
run_i=1
run_array=list()
for (h2_p in c(0.1,0.2,0.3,0.4,0.5)){ #h2 poly
  for (N_causal_SNPs in c(95593)){ #N of causal SNPs
    for (vr in c(0.01,0.02,0.03,0.05,0.10)){ #h2 rare (var rare)
      for (freq_r in c(1e-4,0.001,0.005,0.01,0.05)){ #freq rare
        for (k in c(0.001,0.005,0.01,0.02,0.05)){ #prevalence
          for (genetic_model in c(1,2,3)){ #genetic architecture
            for (pi0 in c(0,0.1,0.3,0.5,0.7,0.9)[1]){  #pi0, proportion of causal variants pi0=0: utility; pi0!=0: power
              run_array[[run_i]]=c(h2_p,N_causal_SNPs,vr,freq_r,k,genetic_model,pi0)
              run_i=run_i+1
            }
          }
        }
      }
    }
  }
}

run_array<-run_array[[subjob_id]]
h2_p=run_array[1]
#N_causal_SNPs=run_array[2]
vr=run_array[3]
freq_r=run_array[4]
k=run_array[5]
N_samples=run_array[6]
genetic_model=switch(run_array[6],'a','b','c')
# a=Infinitesimal architecture
# b=with negative selection
# c=LD-adjusted kinship
pi0=run_array[7]

#load LDsc
ldsc<-read.table('/data/c***/z***/projects/prslev/geno/ldsc/ldsc.simulation_all_snps',header = T,stringsAsFactors = F)

#load common snp table
common_all<-read.table('/data/c***/z***/projects/prslev/common/common_all.bim',header = F,stringsAsFactors = F)
common_all<-data.frame(rsid=common_all$V2,counted_allele=common_all$V5,effect=NA,stringsAsFactors = F)

#load MAF for all the common variants (used for maf-dependent genetic architectures)
maf_all<-read.table('/data/c***/z***/projects/prslev/geno/geno_copies/common_all.frq',header = T,stringsAsFactors = F)

#n of causal common variants
N_causal_SNPs=nrow(common_all)

#load rare snps
rare_dosage<-readRDS('/data/c***/z***/data/biovu/geno/23k/prslev_simulation_rare.rds')
colnames(rare_dosage)[-1]<-sapply(colnames(rare_dosage)[-1], function(x) strsplit(x,"[_]")[[1]][1])
rare_all<-data.frame(rsid=colnames(rare_dosage)[-1],effect=NA,stringsAsFactors = F)

#load rare variant info (freq)
rare_info<-read.table(paste0('/data/c***/z***/data/biovu/geno/chr/rare/rare.list'),header = T,stringsAsFactors = F)
rare_info$SNP=paste0('X',sub(':','.',rare_info$SNP)) #match variants name with dosage data
rare_info<-rare_info[rare_info$maf==freq_r,]

rare=rare_all[which(rare_all$rsid %in% rare_info$SNP),]

#allele frequency for rare variants (the actual number of freq, close to the setting)
freq_snp=sapply(rare$rsid,function(x) rare_info[which(rare_info$SNP==x),'maf'])
#calculate the effect size for rare vatiants
rare$effect=(vr/2/freq_snp/(1-freq_snp))^0.5
#sample N rare variants for simulation (N= number of simulation times)
set.seed(2019)
rare<-rare[sample(nrow(rare),N_simulation,replace = T),]

#simulation
N_samples=10000;i=1 #for testing

for (N_samples in c(500,1000,2000,3000,5000,10000)){
  print(N_samples)

  #output dataframe (liability-threshold model (LTM), probit)
  output_p<-data.frame(h2_p=h2_p,N_causal_SNPs=N_causal_SNPs,vr=vr,freq_r=freq_r,N_samples=N_samples,k=k,pi0=pi0,seed=seq(1,N_simulation),model=genetic_model)

  #output dataframe (logit)
  output_l<-data.frame(h2_p=h2_p,N_causal_SNPs=N_causal_SNPs,vr=vr,freq_r=freq_r,N_samples=N_samples,k=k,pi0=pi0,seed=seq(1,N_simulation),model=genetic_model)

  for (i in 1:N_simulation){
    print(i)

    #---generate effect sizes for common variants according to different genetic architectures---
    df<-common_all
    # a Infinitesimal architecture
    #   beta_poly~(0,h2_p/N_caucal_SNPs)
    if(genetic_model=='a'){
      set.seed(i)
      df$effect=(1-pi0)*rnorm(N_causal_SNPs,0,(h2_p/N_causal_SNPs)^0.5)

      # b Negative selection
      #   beta_poly~N(O,k_constant([f(1-f)]^(1+alpha)))
    }else if(genetic_model=='b'){
      set.seed(i)
      df$effect=df[,'effect']<-sapply(maf_all$MAF,function(f) rnorm(1,mean=0,sd=((f*(1-f))^0.63)^0.5))
      #find k constant
      k_constant=(h2_p/N_causal_SNPs/var(df[,'effect']))
      #multiply by k constant
      df[,'effect']<-df[,'effect']*k_constant^0.5*(1-pi0)

      # c LD-adjusted kinship
      #   beta_poly~N(O,k_constant([f(1-f)]^(1+alpha)*(1/(1+ldsc))))
    }else if(genetic_model=='c'){
      set.seed(i)
      df$effect=df[,'effect']<-mapply(function(f,ld) rnorm(1,mean=0,sd=(((f*(1-f))^0.75)*1/(1+ld))^0.5), maf_all$MAF, ldsc$ldscore)
      #find k constant
      k_constant=(h2_p/N_causal_SNPs/var(df[,'effect']))
      #multiply by k constant
      df[,'effect']<-df[,'effect']*k_constant^0.5*(1-pi0)
    }

    #write weight file
    write.table(df,paste0('/data/g***/z***/prslev/tmp/',subjob_id,'.weight'),row.names = F,col.names = F,sep='\t',quote = F)

    #use plink to calculate the PB (PRS of common variants)
    #if(i %in% c(1,101,201,301,401)){
    cmd=paste0('/home/zhoud2/tools/plink2/plink2 --bfile /data/c***/z***/projects/prslev/common/common_all --score /data/g***/z***/prslev/tmp/',subjob_id,'.weight variance-standardize  --out /data/g***/z***/prslev/tmp/',subjob_id,'.score')
    system(cmd,wait = T,ignore.stdout=T,ignore.stderr=T)
    #}

    #load PB results (A)
    PB=read.table(paste0('/data/g***/z***/prslev/tmp/',subjob_id,'.score.sscore'),stringsAsFactors = F)
    PB$IID=PB$V1;PB$A=PB$V5*2*nrow(common_all)
    PB<-PB[,c('IID','A')]

    #LEV (R)
    rare_id=rare[i,'rsid']
    rare_effect=rare[i,'effect']
    R=as.numeric(rare_dosage[,rare_id]*rare_effect)
    LEV<-data.frame(IID=rare_dosage$FID,R=R)

    #merge A and R
    combined<-merge(PB,LEV,by='IID')

    #---sampling subjects---
    set.seed(i)
    combined<-combined[sample(seq(1,nrow(combined)),N_samples,replace = F),]

    #x=A+R
    combined$x=combined$A+combined$R

    #h2_e
    h2_e=1-h2_p-vr

    #probability of disease (same with LTM)
    set.seed(i)
    combined$L=combined$x+rnorm(nrow(combined),0,h2_e^0.5)
    t=quantile(combined$L,1-k)[[1]]
    combined$prob=pnorm(-(t-combined$x)/h2_e^0.5)

    #--------logit model---start-------
    set.seed(i)
    combined$y_binary<-sapply(combined$prob,function(x) rbinom(1,1,x))
    combined$R<-ifelse(combined$R!=0,1,0)

    #test inverse axis in cases only
    if(length(which(combined$y_binary==1 & combined$R==1))>0 & length(which(combined$y_binary==1 & combined$R==0))>0){
      cases<-combined[combined$y_binary==1,]
      #test inverse axis
      ans_inverse<-wilcox.test(cases[cases$R==1,'A'],cases[cases$R==0,'A'],alternative = c("less"))
      output_l[i,'case_inverse_wilcox_p']<-ans_inverse$p.value
    }else{
      output_l[i,'case_inverse_wilcox_p']<-1
    }

    #test inverse axis in controls only
    if(length(which(combined$y_binary==0 & combined$R==1))>0 & length(which(combined$y_binary==0 & combined$R==0))>0){
      controls<-combined[combined$y_binary==0,]
      #test inverse axis
      ans_inverse<-wilcox.test(controls[controls$R==1,'A'],controls[controls$R==0,'A'],alternative = c("less"))
      output_l[i,'control_inverse_wilcox_p']<-ans_inverse$p.value
    }else{
      output_l[i,'control_inverse_wilcox_p']<-1
    }

    #--OR comparision between LEV and PB--
    for (top_p in c(0.01,0.05,0.1)){
      cut_off=quantile(combined$A,1-top_p)[[1]]
      combined$A_binary<-ifelse(combined$A>cut_off,1,0)

      A_check=table(combined$y_binary,combined$A_binary)
      R_check=table(combined$y_binary,combined$R)

      if(length(A_check)==4 & min(A_check)>0 & length(R_check)==4 & min(R_check)>0){
        ans_A<-summary(glm(combined$y_binary~combined$A_binary,family = 'binomial'))
        ans_R<-summary(glm(combined$y_binary~combined$R,family = 'binomial'))

        output_l[i,paste0('A_top_',top_p,'_beta')]<-ans_A$coefficients['combined$A_binary','Estimate']
        output_l[i,paste0('A_top_',top_p,'_se')]<-ans_A$coefficients['combined$A_binary','Std. Error']
        output_l[i,paste0('R_beta')]<-ans_R$coefficients['combined$R','Estimate']
        output_l[i,paste0('R_se')]<-ans_R$coefficients['combined$R','Std. Error']
      }
    }
    #--------logit model---end-------

    #------liability-threshold model (probit) ---start-----
    combined$y_binary<-ifelse(combined$L>t,1,0)
    table_check<-table(combined$y_binary,combined$R)

    #test inverse axis in cases only
    if(length(which(combined$y_binary==1 & combined$R==1))>0 & length(which(combined$y_binary==1 & combined$R==0))>0){
      cases<-combined[combined$y_binary==1,]
      #test inverse axis
      ans_inverse<-wilcox.test(cases[cases$R==1,'A'],cases[cases$R==0,'A'],alternative = c("less"))
      output_p[i,'case_inverse_wilcox_p']<-ans_inverse$p.value
    }else{
      output_p[i,'case_inverse_wilcox_p']<-1
    }

    #test inverse axis in controls only
    if(length(which(combined$y_binary==0 & combined$R==1))>0 & length(which(combined$y_binary==0 & combined$R==0))>0){
      controls<-combined[combined$y_binary==0,]
      #test inverse axis
      ans_inverse<-wilcox.test(controls[controls$R==1,'A'],controls[controls$R==0,'A'],alternative = c("less"))
      output_p[i,'control_inverse_wilcox_p']<-ans_inverse$p.value
    }else{
      output_p[i,'control_inverse_wilcox_p']<-1
    }

    #--OR comparision between LEV and PB--
    for (top_p in c(0.01,0.05,0.1)){
      cut_off=quantile(combined$A,1-top_p)[[1]]
      combined$A_binary<-ifelse(combined$A>cut_off,1,0)

      A_check=table(combined$y_binary,combined$A_binary)
      R_check=table(combined$y_binary,combined$R)

      if(length(A_check)==4 & min(A_check)>0 & length(R_check)==4 & min(R_check)>0){
        ans_A<-summary(glm(combined$y_binary~combined$A_binary,family = 'binomial'))
        ans_R<-summary(glm(combined$y_binary~combined$R,family = 'binomial'))

        output_p[i,paste0('A_top_',top_p,'_beta')]<-ans_A$coefficients['combined$A_binary','Estimate']
        output_p[i,paste0('A_top_',top_p,'_se')]<-ans_A$coefficients['combined$A_binary','Std. Error']
        output_p[i,paste0('R_beta')]<-ans_R$coefficients['combined$R','Estimate']
        output_p[i,paste0('R_se')]<-ans_R$coefficients['combined$R','Std. Error']
      }
    }

    #------liability-threshold model (probit) ---end-----

  }

  #write result liability-threshold (probit)
  write.table(output_p,paste0('/data/g***/z***/prslev/result/probit_',genetic_model,'/h2p_',h2_p,'_nsnp_','all_snps','_vr_',vr,'_freqr_',freq_r,'_k_',k,'_Nsample_',N_samples,'_pi0_',pi0),quote = F,row.names = F,sep='\t')

  #write result logit model
  write.table(output_l,paste0('/data/g***/z***/prslev/result/logit_',genetic_model,'/h2p_',h2_p,'_nsnp_','all_snps','_vr_',vr,'_freqr_',freq_r,'_k_',k,'_Nsample_',N_samples,'_pi0_',pi0),quote = F,row.names = F,sep='\t')

}


library(stringr)
library(ggplot2)
library(data.table)

#function for extracting the cluster Probs, requires STR infile because STRUCTURE likes to chop off the ends of your sample names so I have to use your original file to get your original names
read.STR<-function(STR.in,STR.out){
#read in data
str<-read.table(STR.in,skip=1)
str.out<-readLines(STR.out)
#the next part parses the structure outfile and grabs the q score part
q.tab.id <- grep("Inferred ancestry of individuals:",str.out,
						 value=FALSE)
num.ind <- grep("Run parameters:",str.out,
						 value=FALSE)+1
k.ind<-grep("populations assumed",str.out,
            value=FALSE)
k<-str.out[k.ind]
k<-as.numeric(str_extract_all(k,"[0-9.A-Za-z_]+")[[1]][1])

num.ind<-str.out[num.ind]
num.ind<-as.numeric(str_extract_all(num.ind,"[0-9.A-Za-z_]+")[[1]][1])
q.end.id<-1+num.ind+q.tab.id
q.tab<-str.out[(q.tab.id+2):q.end.id]
qs<-t(sapply(str_extract_all(q.tab,"[0-9.A-Za-z_]+"),as.character))

cols_qs<-dim(qs)[2]

qs<-qs[,c(2,(cols_qs-k+1):(cols_qs))]
qs<-data.frame(qs)
nclust<- k
#this part replaces the names with your original names
 qs[,1]<-str[,1]
write.csv(qs,paste("k",nclust,".csv",sep=""),row.names=F)
}

#this function plots the structure plot, it takes the result of read.STR, it will also optionaly take a file to reorder the plot, if you dont already have one just reorder your outfile from above and save it
plotSTR<-function(Cluster.csv,plt.order=Cluster.csv){
#I turn off warnings because it will tell you about duplicated factors below
oldw <- getOption("warn")
options(warn = -1)
#read data
data<-fread(Cluster.csv)
plt.order<-fread(plt.order)
nclust<-dim(data)[2]-1
#relabel the columns
labs<-c("Sample",paste("Cluster",seq(1:nclust),sep=""))
og.labs<-paste("X",seq(1:(nclust+1)),sep="")
setnames(data,og.labs,labs)
#reorder, this doesnt do anything if you dont supply an order file
data<-data[match(plt.order$X1,data$Sample),]
#remove duplicates, you shouldnt have duplicates anyway
data<-data[!duplicated(data$Sample),]
#I melt here to make the plotting easy
mdata<-melt(data)
names(mdata)<-c("Sample","Species","Probability")
mdata$Sample<-factor(mdata$Sample,levels=data$Sample)
#plot, you can change the palette to something else to explore other color themes
ggplot(mdata,aes(x=Sample,y=Probability,fill=Species))+geom_bar(stat="identity",position="stack")+theme_classic()+ scale_fill_brewer(palette="Spectral")+theme(axis.text.x = element_text(size=5, angle = 90, hjust = 1,colour="black"))
ggsave(paste("k",nclust,"STRplot.pdf",sep=""),width = 20, height = 9)
options(warn = oldw)
}


#----------------------------------------------
# GUION PARA EL ANALISIS DE DATOS DEL EFECTO DEL
# NIVEL DE OXIGENO EN LA FISIOLOGIA DEL CAMARON
# FANTASMA NEOTRYPAEA UNCINATA
#----------------------------------------------
#Limpio espacio de trabajo
rm(list=ls())

#----------------------------------------------
#CREADO 20141006 FL+EN
today<-format(Sys.Date(),"%Y%m%d")
#----------------------------------------------
# Directorios y librerias
#----------------------------------------------
setwd ("~/Insync/Compartida FL+KP+PG/Leiva et al CBP/Datos")
getwd() #Verifica directorio
library(plotrix)
#----------------------------------------------
# Leo y exploro datos
#----------------------------------------------
datos1 <-read.table("finaldata2.csv",header=TRUE, sep=",", dec=".", strip.white=TRUE)
summary(datos1)
datos1$O2_LEVEL.1<-factor(datos1$O2_LEVEL.1, levels=c("R6","R12","Control","H12","H12+R6","H12+R12"))
#-----------------------------------------------
#Creo Matriz de diseño de gráficos (Figure 1)
#-----------------------------------------------
jpeg(paste("4.1. Figure 1 (",today,").jpeg"),height = 18,width = 40,units="cm",quality=100,res=300)
oma(2,2,2,2)
split.screen(c(2,2))
split.screen(rbind(c(0.1,0.78,0.1,0.98),c(0.82,0.95,0.1,0.98)),screen=1)
#1A METABOLIC RATE
screen(5)
par(mar=c(0.5,4.5,3,0))
sd1<-aggregate(MO2~O2_LEVEL,data=datos1,sd)
media1<-aggregate(MO2~O2_LEVEL,data=datos1,mean)
with(media1,plot(O2_LEVEL,MO2,xaxt="n",ylim=c(0,10),xlim=c(-0.1,22.1),
                 pch=21,cex=1.5,bg=c("white",rep("black",4)),
                 las=1,
                 xlab="",#bquote(paste(italic(p),O[2]~"(kPa)",sep="")),
                 ylab=bquote(paste(italic(M),O[2],~"(",mu,"mol ",.(O[2]~h^-1),g^-1,")",sep="")),
                 cex.lab=1.2,cex.axis=1))
with(sd1,plotCI(x=O2_LEVEL,media1$MO2,MO2,add=T,lwd=2,
                pch=21,pt.bg=c("white",rep("black",4)),cex=1.5))
axis(1,at=seq(0,22,0.5),lab=FALSE,tcl=-0.2)
axis(1,at=seq(0,22,1),lab=FALSE,tcl=-0.4)
axis(1,at=seq(0,22,2),lab=seq(0,22,2),tcl=-0.4,cex.axis=1)
axis(2,at=seq(0,10,0.5),lab=FALSE,tcl=-0.2)
axis(2,at=seq(0,10,1),lab=FALSE,tcl=-0.4)
with(media1,lines(O2_LEVEL,media1$MO2,lty=2,lwd=1))
#lines(c(7.5,21.5),c(6.5,6.5),lend=1)
#lines(c(1.5,4.5),c(4.5,4.5))
text(media1$O2_LEVEL,c(4.1,4.5,6.2,6.7,6.2),c("a","a","b","b","b"),cex=1)
abline(v=8.46,lty=2,)
text(0,c(9.5),c("A)"),font=2,cex=1.2)
screen(6)
par(mar=c(0.5,0,3,0))
sd2<-aggregate(MO2.1~O2_LEVEL.1,data=datos1[1:12,],sd)
media2<-aggregate(MO2.1~O2_LEVEL.1,data=datos1[1:12,],mean)
with(media2,plot(c(1,2),MO2.1,xlim=c(0.5,2.5), #define variables x e y
                 #text(media2$O2_LEVEL.1,c(6,12),c("c","a"))
                 yaxt="n",xaxt="n", #anula ejes x e y
                 ylim=c(0,10), #define limites en y
                 pch=21,cex=1.5,bg="white", # tipo y tamaño de simbolo
                 las=1,
                 xlab="",#xlab=bquote(paste(italic(p),O[2]~"(kPa)",sep="")),
                 ylab=""#bquote(paste(italic(M),O[2]," (",mu,"mol ",.(O[2]~h^-1),g^-1,")",sep=""))
                ))
with(sd2,plotCI(c(1,2),media2$MO2.1,MO2.1,add=T,lwd=2,
                pch=21,pt.bg="white",cex=1.5))

axis(1,at=c(1,2),lab=c(6,12),tcl=-0.4,cex.axis=1)
axis(2,at=seq(0,10,0.5),lab=FALSE,tcl=-0.2)
axis(2,at=seq(0,10,1),lab=FALSE,tcl=-0.4)
text(media2$O2_LEVEL.1,c(8.2,6.2),c("c","b"),cex=1)

----------------------------------
# Segundo panel (Oxyhemocyanin)
-----------------------------------
split.screen(rbind(c(0.1,0.78,0.1,0.98),c(0.82,0.95,0.1,0.98)),screen=2)
screen(7)
par(mar=c(0.5,4.5,3,0))
sd3<-aggregate(OXY~O2_LEVEL,data=datos1,sd)
media3<-aggregate(OXY~O2_LEVEL,data=datos1,mean)
with(media3,plot(O2_LEVEL,OXY,xaxt="n",ylim=c(0,2.5),xlim=c(-0.1,22.1),
                 pch=21,cex=1.5,bg=c("white",rep("black",4)),
                 las=1,
                 ylab=expression(paste(Oxy-Hc, " ",(mmol~L^-1))),
                 cex.lab=1.2,cex.axis=1))

with(sd3,plotCI(x=O2_LEVEL,media3$OXY,OXY,add=T,lwd=2,
               pch=21,pt.bg=c("white",rep("black",4)),cex=1.5))
axis(1,at=seq(0,22,0.5),lab=FALSE,tcl=-0.2)
axis(1,at=seq(0,22,1),lab=FALSE,tcl=-0.4)
axis(1,at=seq(0,22,2),lab=seq(0,22,2),tcl=-0.4,cex.axis=1)
axis(2,at=seq(0,2.5,0.125),lab=FALSE,tcl=-0.2)
axis(2,at=seq(0,2.5,0.25),lab=FALSE,tcl=-0.4)
with(media3,lines(O2_LEVEL,media3$OXY,lty=2,lwd=1))
#lines(c(7.5,21.5),c(6.5,6.5),lend=1)
#lines(c(1.5,4.5),c(4.5,4.5))
text(media3$O2_LEVEL,c(1.9,1.43,1.3,1.4,1.4),c("a","b","b","b","b"),cex=1)
#abline(v=8.1,lty=4)
text(0,c(2.375),c("B)"),font=2,cex=1.2)
screen(8)
par(mar=c(0.5,0,3,0))
sd4<-aggregate(OXY.1~O2_LEVEL.1,data=datos1[1:12,],sd)
media4<-aggregate(OXY.1~O2_LEVEL.1,data=datos1[1:12,],mean)
with(media4,plot(c(1,2),OXY.1,xlim=c(0.5,2.5), #define variables x e y
                 yaxt="n",xaxt="n", #anula ejes x e y
                 ylim=c(0,2.5), #define limites en y
                 pch=21,cex=1.5,bg="white", # tipo y tamaño de simbolo
                 las=1,
                 xlab="",cex.axis=1.2,#bquote(paste(italic(p),O[2]~"(kPa)",sep="")),
                 ylab=bquote(paste(italic(M),O[2],~"(",mu,"mol ",.(O[2]~h^-1),g^-1,")",sep="")),
                 cex.lab=1.2,cex.axis=1))
with(sd4,plotCI(c(1,2),media4$OXY.1,OXY.1,add=T,lwd=2,
                pch=21,pt.bg="white",cex=1.5))

axis(1,at=c(1,2),lab=c(6,12),tcl=-0.4,cex.axis=1)
axis(2,at=seq(0,2.5,0.125),lab=FALSE,tcl=-0.2)
axis(2,at=seq(0,2.5,0.25),lab=FALSE,tcl=-0.4)
text(media4$O2_LEVEL.1,c(1.34,1.1),c("b","b"),cex=1)

----------------------------------
# Tercer panel (Hemmolymph protein)
----------------------------------
split.screen(rbind(c(0.1,0.78,0.1,0.98),c(0.82,0.95,0.1,0.98)),screen=3)
screen(9)
par(mar=c(4,4.5,0,0))
sd5<-aggregate(PROT~O2_LEVEL,data=datos1,sd)
media5<-aggregate(PROT~O2_LEVEL,data=datos1,mean)
with(media5,plot(O2_LEVEL,PROT,xaxt="n",ylim=c(0,100),xlim=c(-0.1,22.1),
                 pch=21,cex=1.5,bg=c("white",rep("black",4)),
                 las=1,
                 xlab=bquote(paste(italic(p),O[2]~"(kPa)",sep="")),
                 ylab=expression(paste(Hem-Prot, " ",(mg~mL^-1))),
                 cex.lab=1.2,cex.axis=1))
with(sd5,plotCI(x=O2_LEVEL,media5$PROT,PROT,add=T,lwd=2,
                pch=21,pt.bg=c("white",rep("black",4)),cex=1.5))
axis(1,at=seq(0,22,0.5),lab=FALSE,tcl=-0.2,cex.axis=1)
axis(1,at=seq(0,22,1),lab=FALSE,tcl=-0.4)
axis(1,at=seq(0,22,2),lab=seq(0,22,2),tcl=-0.4,cex.axis=1)
axis(2,at=seq(0,100,10),lab=FALSE,tcl=-0.4)
axis(2,at=seq(0,100,20),lab=FALSE,tcl=-0.4,cex.axis=1)
axis(2,at=seq(0,100,5),lab=FALSE,tcl=-0.2,cex.axis=1)
with(media5,lines(O2_LEVEL,media5$PROT,lty=2,lwd=1))
#lines(c(7.5,21.5),c(6.5,6.5),lend=1)
#lines(c(1.5,4.5),c(4.5,4.5))
text(media5$O2_LEVEL,c(98,82,75,75,75),c("a","ab","b","b","b"),cex=1)
#abline(v=8.1,lty=4)
text(0,c(95),c("C)"),font=2,cex=1.2)
screen(10)
par(mar=c(4,0.1,0,0))
sd6<-aggregate(PROT.1~O2_LEVEL.1,data=datos1[1:12,],sd)
media6<-aggregate(PROT.1~O2_LEVEL.1,data=datos1[1:12,],mean)
with(media6,plot(c(1,2),PROT.1,xlim=c(0.5,2.5), #define variables x e y
                 yaxt="n",xaxt="n", #anula ejes x e y
                 ylim=c(0,100), #define limites en y
                 pch=21,cex=1.5,bg="white", # tipo y tamaño de simbolo
                 las=1,
                 xlab=("Time (h)"),cex.lab=1.2),
                 ylab="")#bquote(paste(italic(M),O[2]," (",mu,"mol ",.(O[2]~h^-1),g^-1,")",sep=""))))
with(sd6,plotCI(c(1,2),media6$PROT.1,PROT.1,add=T,lwd=2,
                pch=21,pt.bg="white",cex=1.5))

axis(1,at=c(1,2),lab=c(6,12),tcl=-0.4,cex.axis=1)
axis(2,at=seq(0,100,10),lab=FALSE,tcl=-0.4)
axis(2,at=seq(0,100,20),lab=FALSE,tcl=-0.4)
axis(2,at=seq(0,100,5),lab=FALSE,tcl=-0.2)
text(media6$O2_LEVEL.1,c(65,65),c("b","b"),cex=1)

----------------------------------
# Cuarto panel (lactate)
----------------------------------
split.screen(rbind(c(0.1,0.78,0.1,0.98),c(0.82,0.95,0.1,0.98)),screen=4)
screen(11)
par(mar=c(4,4.5,0,0))
sd7<-aggregate(LACT~O2_LEVEL,data=datos1,sd)
media7<-aggregate(LACT~O2_LEVEL,data=datos1,mean)
with(media7,plot(O2_LEVEL,LACT,xaxt="n",ylim=c(0,25),xlim=c(-0.1,22.1),
                 pch=21,cex=1.5,bg=c("white",rep("black",4)),
                 las=1,
                 xlab=bquote(paste(italic(p),O[2]~"(kPa)",sep="")),
                 ylab=expression(paste(Hem-Lact, " ",(mmol~L^-1))),
                 cex.lab=1.2,cex.axis=1))
with(sd7,plotCI(x=O2_LEVEL,media7$LACT,LACT,add=T,lwd=2,
                pch=21,pt.bg=c("white",rep("black",4)),cex=1.5))
axis(1,at=seq(0,22,0.5),lab=FALSE,tcl=-0.2)
axis(1,at=seq(0,22,1),lab=FALSE,tcl=-0.4)
axis(1,at=seq(0,22,2),lab=seq(0,22,2),tcl=-0.4,cex.axis=1)
axis(2,at=seq(0,25,2.5),lab=FALSE,tcl=-0.4)
axis(2,at=seq(0,25,5),lab=FALSE,tcl=-0.4)
axis(2,at=seq(0,25,1.25),lab=FALSE,tcl=-0.2)
with(media7,lines(O2_LEVEL,media7$LACT,lty=2,lwd=1))
#lines(c(7.5,21.5),c(6.5,6.5),lend=1)
#lines(c(1.5,4.5),c(4.5,4.5))
text(media7$O2_LEVEL,c(20.5,18,10,8,8),c("a","b","c","c","c"),cex=1)
#abline(v=8.1,lty=4)
text(0,c(23.75),c("D)"),font=2,cex=1.2)
screen(12)
par(mar=c(4,0.1,0,0))
sd8<-aggregate(LACT.1~O2_LEVEL.1,data=datos1[1:12,],sd)
media8<-aggregate(LACT.1~O2_LEVEL.1,data=datos1[1:12,],mean)
with(media8,plot(c(1,2),LACT.1,xlim=c(0.5,2.5), #define variables x e y
                 yaxt="n",xaxt="n", #anula ejes x e y
                 ylim=c(0,25), #define limites en y
                 pch=21,cex=1.5,bg="white", # tipo y tamaño de simbolo
                 las=1,
                 xlab=("Time (h)"),cex.lab=1.2),
                 ylab="")#bquote(paste(italic(M),O[2]," (",mu,"mol ",.(O[2]~h^-1),g^-1,")",sep=""))))
with(sd8,plotCI(c(1,2),media8$LACT.1,LACT.1,add=T,lwd=2,
                pch=21,pt.bg="white",cex=1.5))

axis(1,at=c(1,2),lab=c(6,12),tcl=-0.4,cex.axis=1)
axis(2,at=seq(0,25,2.5),lab=FALSE,tcl=-0.4)
axis(2,at=seq(0,25,5),lab=FALSE,tcl=-0.4)
axis(2,at=seq(0,25,1.25),lab=FALSE,tcl=-0.2)
text(media8$O2_LEVEL.1,c(10,8),c("c","c"),cex=1)

dev.off()
close.screen(all.screens=TRUE)

#--------------------------------
#Figure 2
#--------------------------------

jpeg(paste("Figure 2 (",today,").jpeg"),height = 18,width = 20,units="cm",quality=100,res=300)
par(mfrow=c(2,2),oma=c(0,0,0,0),mar=c(2,5,1,1))
data.plot<-subset(datos1,!(O2_LEVEL.1 %in% c("R6","R12")))
#METABOLIC RATE
sd9<-aggregate(MO2.1~O2_LEVEL.1,data=data.plot,sd)
media9<-aggregate(MO2.1~O2_LEVEL.1,data=data.plot,mean)
bp1=with(media9,barplot(MO2.1,cex.lab=1.2,ylim=c(0,11),las=1,names=O2_LEVEL.1,
        ylab=bquote(paste(italic(M),O[2],~"(",mu,"mol ",.(O[2]~h^-1),g^-1,")",sep="")),
        cex.lab=1.2,cex.axis=1,
        col=c("white","black","gray40","gray90")))
        plotCI(x=bp1,y=media9$MO2.1,uiw=sd9$MO2.1,
        liw=FALSE,add=TRUE,err="y",pch=NA)

axis(2,at=seq(0,10,0.5),lab=FALSE,tcl=-0.2)
axis(2,at=seq(0,10,1),lab=FALSE,tcl=-0.4)
text(bp1,media9$MO2.1+sd9$MO2.1+1,c("a","b","c","a"),cex=1)
text(0.28,c(10.5),c("A)"),font=2,cex=1.2)
box()

#OXYHEMOCYANIN
sd10<-aggregate(OXY.1~O2_LEVEL.1,data=data.plot,sd)
media10<-aggregate(OXY.1~O2_LEVEL.1,data=data.plot,mean)
bp2=with(media10,barplot(OXY.1,cex.lab=1.2,ylim=c(0,2.75),las=1,names=O2_LEVEL.1,
        ylab=expression(paste(Oxy-Hc, " ",(mmol~L^-1))),
        cex.lab=1.2,cex.axis=1,
        col=c("white","black","gray40","gray90")))
        plotCI(x=bp2,y=media10$OXY.1,uiw=sd10$OXY.1,
        liw=FALSE,add=TRUE,err="y",pch=NA)

axis(2,at=seq(0,2.5,0.125),lab=FALSE,tcl=-0.2)
axis(2,at=seq(0,2.5,0.25),lab=FALSE,tcl=-0.4)
text(bp2,media10$OXY.1+sd10$OXY.1+0.22,c("a","b","a","a"),cex=1)
text(0.28,c(2.625),c("B)"),font=2,cex=1.2)
box()

#HEMOLYMPH PROTEIN
sd11<-aggregate(PROT.1~O2_LEVEL.1,data=data.plot,sd)
media11<-aggregate(PROT.1~O2_LEVEL.1,data=data.plot,mean)
sd11<-aggregate(PROT.1~O2_LEVEL.1,data=data.plot,sd)
media11<-aggregate(PROT.1~O2_LEVEL.1,data=data.plot,mean)
bp3=with(media11,barplot(PROT.1,ylim=c(0,110),las=1,names=O2_LEVEL.1,cex.lab=1.2,
        ylab=expression(paste(Hem-Prot, " ",(mg~mL^-1))),
        cex.lab=1.2,cex.axis=1,
        col=c("white","black","gray40","gray90")))
        plotCI(x=bp3,y=media11$PROT.1,uiw=sd11$PROT.1,
        liw=FALSE,add=TRUE,err="y",pch=NA)

axis(2,at=seq(0,100,10),lab=FALSE,tcl=-0.4)
axis(2,at=seq(0,100,20),lab=FALSE,tcl=-0.4,cex.axis=1)
axis(2,at=seq(0,100,5),lab=FALSE,tcl=-0.2,cex.axis=1)
text(bp3,media11$PROT.1+sd11$PROT.1+10,c("a","b","a","a"),cex=1)
text(0.28,c(105),c("C)"),font=2,cex=1.2)
box()

#HEMOLYMPH LACTATE
sd12<-aggregate(LACT.1~O2_LEVEL.1,data=data.plot,sd)
media12<-aggregate(LACT.1~O2_LEVEL.1,data=data.plot,mean)
sd12<-aggregate(LACT.1~O2_LEVEL.1,data=data.plot,sd)
media12<-aggregate(LACT.1~O2_LEVEL.1,data=data.plot,mean)
bp4=with(media12,barplot(LACT.1,cex.lab=1.2,ylim=c(0,27.5),las=1,names=O2_LEVEL.1,
        ylab=expression(paste(Hem-Lact, " ",(mmol~L^-1))),
        cex.lab=1.2,cex.axis=1,
        col=c("white","black","gray40","gray90")))
        plotCI(x=bp4,y=media12$LACT.1,uiw=sd12$LACT.1,
        liw=FALSE,add=TRUE,err="y",pch=NA)

axis(2,at=seq(0,25,5),lab=FALSE,tcl=-0.4)
axis(2,at=seq(0,25,1.25),lab=FALSE,tcl=-0.2)
axis(2,at=seq(0,25,2.5),lab=FALSE,tcl=-0.4,cex.axis=1)
text(bp4,media12$LACT.1+sd12$LACT.1+2.8,c("a","b","a","a"),cex=1)
text(0.28,c(26.25),c("D)"),font=2,cex=1.2)
box()

dev.off()


'
The file "clean_data.r" deletes all the data of those participants who did not finish the experiment, calculates new variables based on original data and attaches these new variables to the original data file. Also, since we would like to compare the difference between participants with altruistic motivation and participants with social norm motivation, we only focus on the data of altruism condition and social norm condition. As a result, we select the data of altruism condition and social norm condition from the original data file. IN the end, we delete the outliers according to the three-standard deviation rule and the boxplot rule.

'

source("project_paths.r")
library(foreign, lib=PATH_OUT_LIBRARY_R)

#####READ ORIGINAL DATA FILE#####
data <- read.csv(paste(PATH_IN_DATA, "gift_giving_original.csv", sep="/"),sep=";",header=T)
#data<-read.csv("data under analyzing_2.csv",sep=";",header=T)
# Initilize new variables
#####MAKE DUMMY VARIABLES:CHANGE ALL NAs IN THE INDEPENDENT VARIABLES TO 0#####
newframe<-data[,c(3,4,5)]
newframe[is.na(newframe)]<-0
data[,c(3,4,5)]<-newframe

#####DELETE ALL ROWS WHICH CONTAIN NAs (DELETE ALL THE PARTICIPANTS WHO DID NOT FINISH THE EXPERIMENT)#####
completedata<-data[complete.cases(data),]

#####CALCULATE NEW VARIABLES AND ATTACH THESE NEW VARIABLES TO THE DATA FILE#####
attach(data)
altruism_ave<-(completedata$Altruism_1+completedata$Altruism_2+completedata$Altruism_3+completedata$Altruism_4)/4
completedata<-data.frame(completedata,altruism_ave)
sn_ave<-(completedata$SN_1+completedata$SN_2+completedata$SN_3)/3
happiness<-(completedata$Happy+completedata$Cheerful+completedata$Thrilled+completedata$Excited)/4
completedata<-data.frame(completedata,sn_ave,happiness)
attach(completedata)
brand_ave<-(Polo.Ralph.Lauren+burberry+diesel+ugg+louisvuitton +clinique +godiva +armani +hugoboss +lacoste +tiffany +longchamp+jimmychoo +sevenforall +bcbg +chanel +Hennessy +Calvin.Klein +Apple +Omega+Tommy.Hilfiger)/21
completedata<-data.frame(completedata,brand_ave)
completedata[,c("Bag")]<-abs(8-completedata[,c("Bag")])
completedata[,c("Jeans")]<-abs(8-completedata[,c("Jeans")])
completedata[,c("Voucher")]<-abs(8-completedata[,c("Voucher")])
completedata[,c("Lens")]<-abs(8-completedata[,c("Lens")])
indulgence_ave<-(Bag+Jeans+Phone+Book+Video+Voucher+Lens+Card)/8
completedata<-data.frame(completedata,indulgence_ave)
colnames(completedata)[85]<-"appropriateness"

#####SELECT DATA OF ALTRUISM CONDITION AND SOCIAL NORM CONDITION#####
al_sn<-completedata[Condition==1|Condition==3,]

#####DELETE PARTICIPANTS WHOSE SCORE OF ALTRUISM_AVE ARE BEYOND 3 STANDARD DEVIATION#####
temp<-al_sn[!abs(al_sn$altruism_ave-mean(al_sn$altruism_ave)/sd(al_sn$altruism_ave))>3,]

#####ACCORDING TO THE BOXPLOT, DELETE OUTLIERS OUT OF INNER FENCES#####
boxplot(al_sn$altruism_ave~al_sn$Condition,range=1.5)
attach(al_sn)
condition1<-al_sn[Altruism==1,]
lh<-quantile(condition1$altruism_ave,probs=0.25)
uh<-quantile(condition1$altruism_ave,probs=0.75)
step<-1.5*(uh-lh)
outlier<-condition1[condition1$altruism_ave>uh+step|condition1$altruism_ave<lh-step,]
as.numeric(rownames(outlier))
as.numeric(rownames(al_sn))
delete123<-al_sn[!rownames(al_sn)%in% 123,]
delete_outlier<-delete123[!rownames(delete123)%in% 165,]
nrow(delete_outlier)
as.numeric(rownames(delete_outlier))

write.table(delete_outlier, file = paste(PATH_OUT_DATA, "delete_outlier.txt", sep="/"))


#  James Rekow

embedGraph = function(M, intGraph){

  #  ARGS: M - number of samples in cohort. Total number of vertices in conGraph
  #        intGraph - connectivity graph describing the connections between interacting
  #                   samples in the cohort
  #
  #  RETURNS: conGraph - connectivity graph describing the connections between all samples
  #                      in the cohort. This adds M - numI vertices with no incident edges
  #                      to intGraph and then randomizes the vertex labels (vertex index)

  #  create base graph with M vertices and no edges
  baseGraph = make_empty_graph(n = M, directed = FALSE)

  #  extract the number of interacting samples
  numI = length(V(intGraph))

  #  select the indices of interacting samples
  intVertices = sample(M, numI)

  #  extract a vector of edges (every two numbers forms an edge) from intGraph
  intGraphEdges = c(t(ends(intGraph, E(intGraph))))

  #  relabel the indices of intGraphEdges so they are now the indices of the interacting
  #  samples
  conGraphEdges = sapply(intGraphEdges, function(x) intVertices[x])

  #  add these new edges to the base graph
  conGraph = add_edges(baseGraph, edges = conGraphEdges)

  return(conGraph)

} #  end embedGraph function


# Only here to make it easier to use, should not be here.
data2a <- read.csv("data.txt")

removeNA <- function(data) {
	#na.omit(takes data frame) ret: data frame utan na
	return (data[complete.cases(data),])
}

analysePotentialOutliers <- function(data, threshold){
	result <- matrix(, nrow = length(threshold), ncol = 3)
	for(v in 1:length(threshold)) {
		nonOutliers <- vector()
		for(index in 1:nrow(data)) {
			value <- data[index, v]
			if(value <= threshold[v]) {
				nonOutliers <- c(nonOutliers, value)
			}
		}
		result[v,1] <- paste("variable", v)
		result[v,2] <- length(data[, v]) - length(nonOutliers)
		result[v,3] <- mean(nonOutliers)
	}
	colnames(result) <- c("Variable", "NrPotentialOutliers", "MeanNoOutliers")
	print(result)
}


#` Filtering of cells with below a given number of non-zero features
#` @param bmat            (matrix)   A saparse matrix with rows of features and columns of cells
#` @param features_number (interger) Filter the cells if they have less than this number (default:100)
#` @return                (matrix)   A filtered sparse matrix
filter_cells = function(bmat, feature_number=100) {
  bmat = bmat[, Matrix::colSums(bmat) >= feature_number]
  return(bmat)
}