###
#  transition matrix analysis
#  predictor: urban status of childhood residence
#  6 tables for 6 subsets of data
###

rm(list=ls())
# PREPARE URBANIZATION DATA
library(dplyr)
library(tidyr)
source("inread.r")

# read in data
df <- inread("data/mbc_kid_cp.csv") # linguistic
almost_everything <- inread('data/2015_lmsim_data.csv') # geographic
# join residence data to language data
df <- left_join(df, select(
		almost_everything, Subject_Code, Urban_Status.x, Urban_Status.y),
		by = "Subject_Code")
rm(almost_everything)

# set up rural-to-urban ordering
orderXZC <- function(myvar){
  x <- factor(myvar,
	levels = c("XIANG_RURAL","ZHEN_TOWN","CHENG_CITY", "UNKNOWN"),
    labels=c("Rural","Town","Urban","Unknown"),
    ordered=TRUE)
  return(x)
}
df$Urban_Status.x <- orderXZC(df$Urban_Status.x)
df$Urban_Status.y <- orderXZC(df$Urban_Status.y)

# drop rows with missing observations
df <- df[!is.na(df$self.MBC),]
df <- df[!is.na(df$avg.elder.MBC),]
df <- df[!is.na(df$Urban_Status.x),]
df <- df[!is.na(df$Urban_Status.y),]
df <- df[df$Urban_Status.x != "Unknown",]
df <- df[df$Urban_Status.y != "Unknown",]

# set the proper ordering of M, B and C
df$self.MBC <- factor(
	df$self.MBC,
	levels=c("M", "B", "C"),
	labels=c("M.gen2", "B.gen2", "C.gen2"),
	ordered=TRUE)
df$avg.elder.MBC <- factor(
	df$avg.elder.MBC,
	levels=c("M", "B", "C"),
	labels=c("M.gen1", "B.gen1", "C.gen1"),
	ordered=TRUE)

# remove "Unknown" level from Rural-to-Urban factor
df$Urban_Status.x <- factor(
	df$Urban_Status.x,
	levels=c("Rural", "Town", "Urban"),
	ordered=TRUE)
df$Urban_Status.y <- factor(df$Urban_Status.y,
	levels=c("Rural", "Town", "Urban"),
	ordered=TRUE)

# RUN TRANSITION MATRIX ANALYSIS
xvar <- "urbrur"
df <- rename(df, urbrur = Urban_Status.y) # .y is childhood res
source("tp_matrix_loop.r")


library(tidyverse)

tribble(
  ~x,~y,~z,
  'a',2,3.6,
  'b',1,8.5
)


#' @title Bland-Altman drawing function for R
#'
#' @description Bland-Altman drawing function. Depends on the blandr.statistics function in the package. Will generate a plot via the standard R plotting functions.
#'
#' @author Deepankar Datta <deepankardatta@nhs.net>
#'
#' @note Started 2015-11-14
#' @note Last update 2015-11-19
#' @note Originally designed for LAVAS and CVLA
#'
#' @param method1 A list of numbers.
#' @param method2 A list of numbers.
#' @inheritParams blandr.statistics
#' @inheritParams blandr.plot.limits
#' @inheritParams blandr.plot.ggplot
#'
#' @examples
#' # Generates two random measurements
#' measurement1 <- rnorm(100)
#' measurement2 <- rnorm(100)
#'
#' # Generates a plot, with no optional arguments
#' gg_bland_altman(measurement1, measurement2)
#' @export
gg_bland_altman <- function(method1,
                            method2,
                            method1name = "Method 1",
                            method2name = "Method 2",
                            plotTitle = "Bland-Altman plot for comparison of 2 methods",
                            sig.level = 0.95,
                            LoA.mode = 1,
                            ciDisplay = TRUE,
                            ciShading = TRUE,
                            ciFillColors = c("steelblue3", "gray85"),
                            normalLow = FALSE,
                            normalHigh = FALSE,
                            lowest_y_axis = FALSE,
                            highest_y_axis = FALSE,
                            point_size = 0.8,
                            overlapping = FALSE,
                            x.plot.mode = "means",
                            y.plot.mode = "difference",
                            plotProportionalBias = FALSE,
                            plotProportionalBias.se = TRUE,
                            assume.differences.are.normal = TRUE) {

  # Passes data to the blandr.statistics function to generate Bland-Altman statistics
  statistics.results <- blandr.statistics(method1, method2, sig.level, LoA.mode)

  # Passed data to the blandr.plot.limits function to generate plot limits
  # Only used for the basic R plots
  plot.limits <- blandr.plot.limits(statistics.results, lowest_y_axis, highest_y_axis)

  # Plots data

  # Pass data to the blandr.plot.ggplot function to use ggplot2 graphics system
  ba.plot <- blandr.plot.ggplot(
    statistics.results = statistics.results,
    method1name = method1name,
    method2name = method2name,
    plotTitle = plotTitle,
    ciDisplay = ciDisplay,
    ciShading = ciShading,
    ciFillColors = ciFillColors,
    normalLow = normalLow,
    normalHigh = normalHigh,
    overlapping = overlapping,
    x.plot.mode = x.plot.mode,
    y.plot.mode = y.plot.mode,
    point_size = point_size,
    plotProportionalBias = plotProportionalBias,
    plotProportionalBias.se = plotProportionalBias.se,
    assume.differences.are.normal = assume.differences.are.normal
  )
  return(ba.plot)
  # END OF FUNCTION
}

#' @title Data preparation for method comparison analysis
#'
#' @description Prepares the data and runs error checks before the calling function runs whatever method analysis mode is wants.
#'
#' @author Deepankar Datta <deepankardatta@nhs.net>
#'
#' @param method1 A list of numbers.
#' @param method2 A list of numbers.
#' @param sig.level Significance level. Is not optional in this function, as the calling package should have a default value to pass if needed
#'
#' @return method.comparison A data frame of paired values. These have been data checked, and empty rows omitted, from the originally supplied data.
#'
#' @examples
#' # Generates two random measurements
#' measurement1 <- rnorm(100)
#' measurement2 <- rnorm(100)
#'
#' # Calls the function - do note that this function was really
#' # meant to be called from other functions and not a stand-alone funtion
#' blandr.data.preparation(measurement1, measurement2, sig.level = 0.95)
#' @export
blandr.data.preparation <- function(method1, method2, sig.level) {

  # Put everything into a data frame for easier handling Stems from the error in some of
  # the sepsis data I had
  method.comparison <- data.frame(method1, method2)

  # Omit rows which have empty values
  method.comparison <- na.omit(method.comparison)

  # Data checks
  if (length(method.comparison$method1) != length(method.comparison$method2)) {
    stop("Method comparison analysis error: the 2 methods must have paired values.")
  }
  if (!is.numeric(method.comparison$method1)) {
    stop("Method comparison analysis error: the first method is not a number.")
  }
  if (!is.numeric(method.comparison$method2)) {
    stop("Method comparison analysis error: the second method is not a number.")
  }
  if (sig.level < 0) {
    stop("Method comparison analysis error: you can't have a significance level less than 0.")
  }
  if (sig.level < 0.8) {
    warning("Method comparison analysis warning: do you really want a significance level <0.8?")
  }
  if (sig.level > 1) {
    stop("Method comparison analysis error: you can't have a significance level greater than 1.")
  }
  if (sig.level == 1) {
    warning("Method comparison analysis warning: selecting a significance level of 1 suggest that probability testing might not be what you need.")
  }

  # Returns the data
  return(method.comparison)
}

#' @title Bland-Altman plotting function, using ggplot2
#'
#' @description Draws a Bland-Altman plot using data calculated using the other functions, using ggplot2
#'
#' @author Deepankar Datta <deepankardatta@nhs.net>
#'
#' @param statistics.results A list of statistics generated by the blandr.statistics function: see the function's return list to see what variables are passed to this function
#' @param method1name (Optional) Plotting name for 1st method, default "Method 1"
#' @param method2name (Optional) Plotting name for 2nd method, default "Method 2"
#' @param plotTitle (Optional) Title name, default "Bland-Altman plot for comparison of 2 methods"
#' @param point_size (Optional) Default = 0.8
#' @param ciDisplay (Optional) TRUE/FALSE switch to plot confidence intervals for bias and limits of agreement, default is TRUE
#' @param ciShading (Optional) TRUE/FALSE switch to plot confidence interval shading to plot, default is TRUE
#' @param ciFillColors (Optional) 2-vector of colors to use in the bias shading and confidence band shading
#' @param normalLow (Optional) If there is a normal range, entering a continuous variable will plot a vertical line on the plot to indicate its lower boundary
#' @param normalHigh (Optional) If there is a normal range, entering a continuous variable will plot a vertical line on the plot to indicate its higher boundary
#' @param overlapping (Optional) TRUE/FALSE switch to increase size of plotted point if multiple values using ggplot's geom_count, deafault=FALSE. Not currently recommend until I can tweak the graphics to make them better
#' @param x.plot.mode (Optional) Switch to change x-axis from being plotted by means (="means") or by either 1st method (="method1") or 2nd method (="method2"). Default is "means". Anything other than "means" will switch to default mode.
#' @param y.plot.mode (Optional) Switch to change y-axis from being plotted by difference (="difference") or by proportion magnitude of measurements (="proportion"). Default is "difference". Anything other than "proportional" will switch to default mode.
#' @param plotProportionalBias (Optional) TRUE/FALSE switch. Plots a proportional bias line. Default is FALSE.
#' @param plotProportionalBias.se (Optional) TRUE/FALSE switch. If proportional bias line is drawn, switch to plot standard errors. See stat_smooth for details. Default is TRUE.
#' @param assume.differences.are.normal (Optional, not operationally used currently) Assume the difference of means has a normal distribution. Will be used to build further analyses
#'
#' @return ba.plot Returns a ggplot data set that can then be plotted
#'
#' @import ggplot2
#'
#' @examples
#' # Generates two random measurements
#' measurement1 <- rnorm(100)
#' measurement2 <- rnorm(100)
#'
#' # Generates a ggplot
#' # Do note the ggplot function wasn't meant to be used on it's own
#' # and is generally called via the bland.altman.display.and.draw function
#'
#' # Passes data to the blandr.statistics function to generate Bland-Altman statistics
#' statistics.results <- blandr.statistics(measurement1, measurement2)
#'
#' # Generates a ggplot, with no optional arguments
#' blandr.plot.ggplot(statistics.results)
#'
#' # Generates a ggplot, with title changed
#' blandr.plot.ggplot(statistics.results, plotTitle = "Bland-Altman example plot")
#'
#' # Generates a ggplot, with title changed, and confidence intervals off
#' blandr.plot.ggplot(statistics.results,
#'   plotTitle = "Bland-Altman example plot",
#'   ciDisplay = FALSE, ciShading = FALSE
#' )
#' @export

blandr.plot.ggplot <- function(statistics.results,
                               method1name = "Method 1",
                               method2name = "Method 2",
                               plotTitle = "Bland-Altman plot for comparison of 2 methods",
                               point_size = 0.8,
                               ciDisplay = TRUE,
                               ciShading = TRUE,
                               ciFillColors = c("steelblue3", "gray85"),
                               normalLow = FALSE,
                               normalHigh = FALSE,
                               overlapping = FALSE,
                               x.plot.mode = "means",
                               y.plot.mode = "difference",
                               plotProportionalBias = FALSE,
                               plotProportionalBias.se = TRUE,
                               assume.differences.are.normal = TRUE) {

  # Does a check if ggplot2 is available
  # It should be as it is in the imports section but in CRAN checks some systems don't have it!
  if (!requireNamespace("ggplot2", quietly = TRUE)) {
    stop("Package \"ggplot2\" needed for this function to work. Please install it.",
      call. = FALSE
    )
  }

  # Selects if x-axis uses means (traditional) or selects one of the methods
  # as the gold standard (non-traditional BA)
  # See Krouwer JS (2008) Why Bland-Altman plots should use X, not (Y+X)/2 when X is a reference method. Statistics in Medicine 27:778-780
  # NOT ENABLED YET
  x.axis <- statistics.results$means

  # Selects if uses differences (traditional) or proportions (non-traditional BA)
  if (y.plot.mode == "proportion") {
    y.axis <- statistics.results$proportion
  } else {
    y.axis <- statistics.results$differences
  }

  # Constructs the plot.data dataframe
  plot.data <- data.frame(x.axis, y.axis)

  # Rename to allow plotting
  # This was a hangover from an older version so I'm not sure we need it anymore
  # But not really a priority to check and remove now
  colnames(plot.data)[1] <- "x.axis"
  colnames(plot.data)[2] <- "y.axis"

  # Plot using ggplot
  ba.plot <- ggplot(plot.data, aes(x = x.axis, y = y.axis))

  # Drawing confidence intervals (OPTIONAL) -- put this here so that it appears under the points
  if (ciDisplay == TRUE) {
    ba.plot <- ba.plot +
      geom_hline(yintercept = statistics.results$biasUpperCI, linetype = 3) + # Bias - upper confidence interval
      geom_hline(yintercept = statistics.results$biasLowerCI, linetype = 3) + # Bias - lower confidence interval
      geom_hline(yintercept = statistics.results$upperLOA_upperCI, linetype = 3) + # Upper limit of agreement - upper confidence interval
      geom_hline(yintercept = statistics.results$upperLOA_lowerCI, linetype = 3) + # Upper limit of agreement - lower confidence interval
      geom_hline(yintercept = statistics.results$lowerLOA_upperCI, linetype = 3) + # Lower limit of agreement - upper confidence interval
      geom_hline(yintercept = statistics.results$lowerLOA_lowerCI, linetype = 3) # Lower limit of agreement - lower confidence interval

    # Shading areas for 95% confidence intervals (OPTIONAL)
    # This needs to be nested into the ciDisplay check
    if (ciShading == TRUE) {
      ba.plot <- ba.plot +
        annotate("rect", xmin = -Inf, xmax = Inf, ymin = statistics.results$biasLowerCI, ymax = statistics.results$biasUpperCI, fill = ciFillColors[1], alpha = 0.3) + # Bias confidence interval shading
        annotate("rect", xmin = -Inf, xmax = Inf, ymin = statistics.results$upperLOA_lowerCI, ymax = statistics.results$upperLOA_upperCI, fill = ciFillColors[2], alpha = 0.3) + # Upper limits of agreement confidence interval shading
        annotate("rect", xmin = -Inf, xmax = Inf, ymin = statistics.results$lowerLOA_lowerCI, ymax = statistics.results$lowerLOA_upperCI, fill = ciFillColors[2], alpha = 0.3) # Lower limits of agreement confidence interval shading
    }
  }

  # continue plotting
  ba.plot <- ba.plot +
    geom_point(size = point_size) +
    theme(plot.title = element_text(hjust = 0.5)) +
    geom_hline(yintercept = 0, linetype = 1) + # "0" line
    geom_hline(yintercept = statistics.results$bias, linetype = 2) + # Bias
    geom_hline(yintercept = statistics.results$bias + (statistics.results$biasStdDev * statistics.results$sig.level.convert.to.z), linetype = 2) + # Upper limit of agreement
    geom_hline(yintercept = statistics.results$bias - (statistics.results$biasStdDev * statistics.results$sig.level.convert.to.z), linetype = 2) + # Lower limit of agreement
    ggtitle(plotTitle) +
    xlab("Means")

  # Re-titles the y-axis dependent on which plot option was used
  if (y.plot.mode == "proportion") {
    ba.plot <- ba.plot + ylab("Difference / Average %")
  } else {
    ba.plot <- ba.plot + ylab("Differences")
  }

  ### Function has finished drawing of confidence intervals at this line

  # If a normalLow value has been sent, plots this line
  if (normalLow != FALSE) {
    # Check validity of normalLow value to plot line
    if (is.numeric(normalLow) == TRUE) {
      ba.plot <- ba.plot + geom_vline(xintercept = normalLow, linetype = 4, col = 6)
    }
  }

  # If a normalHighvalue has been sent, plots this line
  if (normalHigh != FALSE) {
    # Check validity of normalHigh value to plot line
    if (is.numeric(normalHigh) == TRUE) {
      ba.plot <- ba.plot + geom_vline(xintercept = normalHigh, linetype = 4, col = 6)
    }
  }

  # If overlapping=TRUE uses geom_count
  # See the param description at the top
  if (overlapping == TRUE) {
    ba.plot <- ba.plot + geom_count()
  }

  # If plotProportionalBias switch is TRUE, plots a proportional bias line as well
  if (plotProportionalBias == TRUE) {

    # Check for validity of options passed to the plotProportionalBias.se switch
    # As if we throw an invalid option to ggplot it will just stop with an error
    if (plotProportionalBias.se != TRUE && plotProportionalBias.se != FALSE) {
      plotProportionalBias.se <- TRUE
    }

    # Plots line
    ba.plot <- ba.plot + ggplot2::geom_smooth(method = "lm", se = plotProportionalBias.se)
  } # End of drawing proportional bias line

  # Draws marginal histograms if option selected
  # Idea from http://labrtorian.com/tag/bland-altman/
  # REMOVED AS INTRODUCED SOME INCOMPATIBILITIES DEPENDENT ON USERS R VERSION
  # ALSO MASSIVELY INCREASED PACKAGE SIZE
  # if( marginalHistogram == TRUE ) { ba.plot <- ggMarginal( ba.plot , type="histogram" ) }

  # Return the ggplot2 output
  return(ba.plot)

  # END OF FUNCTION
}

#' @title Bland-Altman plot limits for R
#'
#' @description Works out plot limits for the Bland-Altman plots. Depends on the blandr.statistics function in the package.
#'
#' @author Deepankar Datta <deepankardatta@nhs.net>
#'
#' @param statistics.results A list of statistics generated by the blandr.statistics function: see the function's return list to see what variables are passed to this function
#' @param lowest_y_axis (Optional) Defaults to NULL If given a continuous variable will use this as the lower boundary of the y axis. Useful if need multiple plots with equivalent y-axes.
#' @param highest_y_axis (Optional) Defaults to NULL If given a continuous variable will use this as the upper boundary of the y axis. Useful if need multiple plots with equivalent y-axes.
#' @return x_upper The upper limit of the X-axis
#' @return x_lower The lower limit of the X-axis
#' @return y_upper The upper limit of the Y-axis
#' @return y_lower The lower limit of the Y-axis
#'
#' @examples
#' # Generates two random measurements
#' measurement1 <- rnorm(100)
#' measurement2 <- rnorm(100)
#'
#' # Passes data to the blandr.statistics function to generate Bland-Altman statistics
#' statistics.results <- blandr.statistics(measurement1, measurement2)
#'
#' # Calls the function
#' blandr.plot.limits(statistics.results)
#' @export

blandr.plot.limits <- function(statistics.results, lowest_y_axis = FALSE, highest_y_axis = FALSE) {

  # Calculates a margin for error - therefore labelled bounds
  x_bounds <- (max(statistics.results$means) - min(statistics.results$means)) * 0.1 ### this is a margin of error for drawing the x axis
  y_bounds <- (max(statistics.results$differences) - min(statistics.results$differences)) *
    0.1 ### this is a margin of error for drawing the y axis

  # Sets limits for plot on the x-axis
  x_upper <- max(statistics.results$means) + x_bounds
  x_lower <- min(statistics.results$means) - x_bounds

  # Sets limits for plot on the y-axis
  y_upper <- max(statistics.results$differences) + y_bounds
  y_lower <- min(statistics.results$differences) - y_bounds

  # Ensures that y-axis includes the whole range of confidence intervals
  if (y_upper <= statistics.results$upperLOA_upperCI) {
    y_upper <- statistics.results$upperLOA_upperCI + y_bounds
  }
  if (y_lower >= statistics.results$lowerLOA_lowerCI) {
    y_lower <- statistics.results$lowerLOA_lowerCI - y_bounds
  }

  # If the user has requested specific limits to the y-axis the following 2 lines execute
  # this
  if (highest_y_axis != FALSE) {
    y_upper <- highest_y_axis
  }
  if (lowest_y_axis != FALSE) {
    y_lower <- lowest_y_axis
  }

  return(
    list(x_upper = x_upper, x_lower = x_lower, y_upper = y_upper, y_lower = y_lower) # CLOSE OF LIST
  ) # CLOSE OF RETURN

  # END OF FUNCTION
}

#' @title Bland-Altman statistics for R
#'
#' @description Bland-Altman analysis function for R. Package created as existing
#' functions don't suit my needs, and don't generate 95\% confidence intervals
#' for bias and limits of agreement. This base function calculates the basic
#' statistics, and generates return values which can be used in the related
#' \code{blandr.display} and \code{bland.altamn.plot} functions. However
#' the return results can be used to generate a custom chart if desired.
#'
#' @author Deepankar Datta <deepankardatta@nhs.net>
#'
#' @note The function will give similar answers when used on the original Bland-Altman PEFR data sets. They won't be exactly the same as (a) for 95\% limits of agreement I have used +/-1.96, rather than 2, and (b) the computerised calculation means that the rounding that is present in each step of the original examples does not occur. This will give a more accurate answer, although I can understand why in 1986 rounding would occur at each step for ease of calculation.
#' @note The function depends on paired values.
#' @note It currently only can currently work out fixed bias.
#' @note Improvements for the future: proportional bias charts will need further work
#'
#' @note Started 2015-11-14
#' @note Last update 2016-02-04
#' @note Originally designed for LAVAS and CVLA
#'
#' @references Based on: (1) Bland, J. M., & Altman, D. (1986). Statistical methods for assessing agreement between two methods of clinical measurement. The Lancet, 327(8476), 307-310. http://dx.doi.org/10.1016/S0140-6736(86)90837-8
#' @references Confidence interval work based on follow-up paper: (2) Altman, D. G., & Bland, J. M. (2002). Commentary on quantifying agreement between two methods of measurement. Clinical chemistry, 48(5), 801-802. http://www.clinchem.org/content/48/5/801.full.pdf
#'
#' @param x Either a formula, or a vector of numbers corresponding to the results from method 1.
#' @param y A vector of numbers corresponding to the results from method 2. Only needed if \code{X} is a vector.
#' @param sig.level (Optional) Two-tailed significance level. Expressed from 0 to 1. Defaults to 0.95.
#' @param LoA.mode (Optional) Switch to change how accurately the limits of agreement (LoA) are calculated from the bias and its standard deviation. The default is LoA.mode=1 which calculates LoA with the more accurate 1.96x multiplier. LoA.mode=2 uses the 2x multiplier which was used in the original papers. This should really be kept at default, except to double check calculations in older papers.
#'
#' @return An object of class 'blandr' is returned. This is a list with the following elements:
#' \item{means}{List of arithmetic mean of the two methods}
#' \item{differences}{List of differences of the two methods}
#' \item{method1}{Returns the 'method1' list in the data frame if further evaluation is needed}
#' \item{method2}{Returns the 'method2' list in the data frame if further evaluation is needed}
#' \item{sig.level}{Significance level supplied to the function}
#' \item{sig.level.convert.to.z}{Significance level convert to Z value}
#' \item{bias}{Bias of the two methods}
#' \item{biasUpperCI}{Upper confidence interval of the bias (based on significance level)}
#' \item{biasLowerCI}{Lower confidence interval of the bias (based on significance level)}
#' \item{biasStdDev}{Standard deviation for the bias}
#' \item{biasSEM}{Standard error for the bias}
#' \item{LOA_SEM}{Standard error for the limits of agreement}
#' \item{upperLOA}{Upper limit of agreement}
#' \item{upperLOA_upperCI}{Upper confidence interval of the upper limit of agreement}
#' \item{upperLOA_lowerCI}{Lower confidence interval of the upper limit of agreement}
#' \item{lowerLOA}{Lower limit of agreement}
#' \item{lowerLOA_upperCI}{Upper confidence interval of the lower limit of agreement}
#' \item{lowerLOA_lowerCI}{Lower confidence interval of the lower limit of agreement}
#' \item{proportion}{Differences/means*100}
#' \item{no.of.observations}{Number of observations}
#' \item{regression.equation}{A regression equation to help determine if there is any proportional bias}
#' \item{regression.fixed.slope}{The slope value of the regression equation}
#' \item{regression.fixed.intercept}{The intercept value of the regression equation}
#'
#' @importFrom stats coef cor lm na.omit qnorm qt sd t.test
#'
#' @examples
#'
#' # Generates two random measurements
#' measurement1 <- rnorm(100)
#' measurement2 <- rnorm(100)
#'
#' # Generates Bland-Altman statistics data of the two measurements
#' blandr.statistics(measurement1, measurement2)
#' @rdname blandr.statistics
#' @export
blandr.statistics <- function(x,
                              y,
                              sig.level = 0.95,
                              LoA.mode = 1) {

  # This sends to the preparation function, which does some sense checks on the data And
  # makes sure that the values are prepared
  method1 <- x
  method2 <- y
  ba.data <- blandr.data.preparation(method1, method2, sig.level)

  # method1 and method2 are the measurements
  means <- (ba.data$method1 + ba.data$method2) / 2
  differences <- ba.data$method1 - ba.data$method2
  bias <- mean(differences)
  biasStdDev <- sd(differences)

  # Convert confidence interval to a two-tailed z-value Don't really need this but kept as
  # a remnant of old version to possibly use in the future
  alpha <- 1 - sig.level
  sig.level.two.tailed <- 1 - (alpha / 2)
  sig.level.convert.to.z <- qnorm(sig.level.two.tailed)

  # Compute the 95% limits of agreement (based on 1st paper) Don't use the significance
  # level supplied to the function here!  (The significance level is for confidence
  # intervals, not for limits of agreement!)  We want to know in the sample what limits 95%
  # of the pop resides within The LoA.mode switch can change before the +/-1.96 multiplier
  # used in more recent papers Or the estimated +/-2 multiplier used in the original paper
  # The default is LoA.mode which gives a LoA.multiplier of 1.96. In future we could use an
  # even more precise multipler for limits of agreement.
  if (LoA.mode == 2) {
    LoA.multiplier <- 2
  } else {
    LoA.multiplier <- 1.96
  }
  upperLOA <- bias + (LoA.multiplier * biasStdDev)
  lowerLOA <- bias - (LoA.multiplier * biasStdDev)

  # Confidence intervals (based on 2nd paper) Based on significance level supplied
  # (defaults to 95% CI) CI for mean
  biasSEM <- sd(differences) / sqrt(length(differences))
  biasCI <- qt(sig.level.two.tailed, df = length(differences) - 1) * biasSEM
  biasUpperCI <- bias + biasCI
  biasLowerCI <- bias - biasCI

  # CI for limits of agreement LOAVariance from Carkeet
  LOAVariance <- ((1 / length(differences)) + ((sig.level.convert.to.z^2) / (2 * (length(differences) -
    1)))) * biasStdDev^2
  LOA_SEM <- sqrt(LOAVariance)
  LOA_CI <- qt(sig.level.two.tailed, df = length(differences) - 1) * LOA_SEM
  upperLOA_upperCI <- upperLOA + LOA_CI
  upperLOA_lowerCI <- upperLOA - LOA_CI
  lowerLOA_upperCI <- lowerLOA + LOA_CI
  lowerLOA_lowerCI <- lowerLOA - LOA_CI

  # Difference/mean proportion
  proportion <- differences / means * 100

  # Number of observations
  no.of.observations <- length(means)

  # Works out numbers for proportional bias
  # Couldn't figure this out myself So took example code from
  # http://rforpublichealth.blogspot.co.uk/2013/11/ggplot2-cheatsheet-for-scatterplots.html
  m <- lm(differences ~ means)
  a <- signif(coef(m)[1], digits = 2)
  b <- signif(coef(m)[2], digits = 2)
  regression.equation <- paste("y(differences) = ", b, " x(means) + ", a, sep = "")

  results <-
    list(
      means = means,
      differences = differences,
      method1 = method1,
      method2 = method2,
      sig.level = sig.level,
      sig.level.convert.to.z = sig.level.convert.to.z,
      bias = bias,
      biasUpperCI = biasUpperCI,
      biasLowerCI = biasLowerCI,
      biasStdDev = biasStdDev,
      biasSEM = biasSEM,
      LOA_SEM = LOA_SEM,
      upperLOA = upperLOA,
      upperLOA_upperCI = upperLOA_upperCI,
      upperLOA_lowerCI = upperLOA_lowerCI,
      lowerLOA = lowerLOA,
      lowerLOA_upperCI = lowerLOA_upperCI,
      lowerLOA_lowerCI = lowerLOA_lowerCI,
      proportion = proportion,
      no.of.observations = no.of.observations,
      regression.equation = regression.equation,
      regression.fixed.slope = b,
      regression.fixed.intercept = a
    ) # CLOSE OF LIST

  class(results) <- "blandr"
  return(results)

  # END OF FUNCTION
}


REBOL [
	System: "REBOL [R3] Language Interpreter and Run-time Environment"
	Title: "REBOL Graphics - DRAW commands"
	Author: ["Richard Smolak" "Carl Sassenrath"]
	Rights: {
		Copyright 2012 REBOL Technologies
		REBOL is a trademark of REBOL Technologies

		Additional code modifications and improvements Copyright 2012 Saphirion AG
	}
	License: {
		Licensed under the Apache License, Version 2.0.
		See: http://www.apache.org/licenses/LICENSE-2.0
	}
	Name: draw
	Type: extension
	Exports: none
	Note: "Run make-host-ext.r to convert"
]

;don't change order of already defined words unless you know what you are doing

words: [
	;fill-rule
	even-odd
	non-zero

	;grad-pen
	conic
	cubic
	diagonal
	diamond
	linear
	radial
	normal
	repeat
	reflect

	;line-cap
	butt
	square
	rounded

	;line-join
	miter
	miter-bevel
	round
	bevel

	;line-width
	variable
	fixed

	;arc
	opened
	closed

	;image
	no-border
	border

	;image-filter
	nearest
	bilinear
	bicubic
	gaussian
	resize
	resample

	;text
	raster
	vectorial
]

;temp hack - will be removed later
init-words: command [
	words [block!]
]

init-words words

;please alphabetize the order of commands so it easier to lookup things

anti-alias: command [
	"Turns anti-aliasing on or off."
	state [logic!]
]

arc: command [
	"Draws a partial section of an ellipse or circle."
	center [pair!] "The center of the circle"
	radius [pair!] "The radius of the circle"
	angle-begin [number!] "The angle where the arc begins, in degrees"
	angle-length [number!] "The length of the arc in degrees"
	'arc-ending [word!] "Leave the arc: OPENED or CLOSED"
]

arrow: command [
	"Sets the arrow mode."
	mode [pair!] "Possible numbers for combination. 0 for none, 1 for head, 2 for tail"
	color [tuple! none!] "Color of the head/tail of the arrow. NONE means use PEN color"
]

box: command [
	"Draws a rectangular box."
	origin [pair!] "Corner of box"
	end [pair!] "End of box"
	corner-radius [number!] "Rounds corners"
]

circle: command [
	"Draws a circle or ellipse."
	center [pair!]
	radius [pair!]
]

curve: command [
	"Draws a smooth Bezier curve.(using 3 or 4 points)"
	point-1 [pair!] "End point A"
	point-2 [pair!] "Control point A"
	point-3 [pair!] "End point B, or control point B"
	point-4 [pair! none!] "End point B"
]

clip: command [
	"Specifies a clipping region."
	origin [pair!] "Corner of box"
	end [pair!] "End of box"
]

ellipse: command [
	"Draws an ellipse."
	origin [pair!] "The upper-left-point of the ellipse bounding box"
	diameter [pair!]
]

fill-pen: command [
	"Sets the area fill pen color."
	color [tuple! image! logic!] "Set to OFF to disable fill pen"
]

fill-rule: command [
	"Determines the algorithm used to determine what area to fill."
	'mode [word!] "Rule type: EVEN-ODD or NON-ZERO"
]

gamma: command [
	"Sets the gamma correction value."
	gamma-value [number!]
]

grad-pen: command [
	"Sets the color gradient for area filling. To disable it set the color block to NONE."
	'type [word!] "The gradient type: RADIAL CONIC DIAMOND LINEAR DIAGONAL CUBIC"
	'mode [word!] "The gradient rendering mode: NORMAL REPEAT REFLECT"
	offset [pair!] "offset from where should the gradient be rendered"
	range [pair!] "begin and end of the gradient range"
	angle [number!] "rotation of the gradient in degrees"
	scale [pair!] "X and Y scale factor"
	colors [block! none!] "block containing up to 256 gradient colors (optionally with color offsets)"
]

image: command [
	"Draws an image, with optional scaling, borders, and color keying."
	image [image!]
	offset-points [pair! block!]
]

image-filter: command [
	"Specifies type of algorithm used when an image is scaled."
	'filter-type [word!] "supported filters: NEAREST, BILINEAR, BICUBIC, GAUSSIAN"
	'filter-mode [word!] "Output quality: RESIZE(low, faster) or RESAMPLE(high, slower)"
	blur [number! none!] "Used only in RESAMPLE mode"
]

image-options: command [
	"Sets options related to image rendering."
	key-color [tuple! none!] "Color to be rendered as transparent or NONE to disable it"
	'border-flag [word!] "can be BORDER or NO-BORDER"
]

image-pattern: command [
	"Configure the image pattern fill settings."
	'pattern-mode [word!] "can be NORMAL, REPEAT or REFLECT"
	pattern-offset [pair!]
	pattern-size [pair!] "set to 0x0 for auto-size"

]

line: command [
	"Draws (poly)line from a number of points."
	lines [block!] "Block of pairs"
]

line-cap: command [
	"Sets the style that will be used when drawing the ends of lines."
	'type [word!] "Cap type: BUTT, SQUARE or ROUNDED"
]

line-join: command [
	"Sets the style that will be used where lines are joined."
	'type [word!] "Join type: MITER, MITER-BEVEL, ROUND, or BEVEL"
]

line-pattern: command [
	"Sets the line pattern. To disable it set the pattern block to NONE."
	color [tuple!] "Dash color"
	pattern [block! none!] "Block of dash-size/stroke-size number pairs"
]

line-width: command [
	"Sets the line width."
	width [number!] "Zero, or negative values, produce a line-width of 1."
	'mode [word!] "Line width mode during scaling: FIXED or VARIABLE"
]

invert-matrix: command [
	"Applies an algebraic matrix inversion operation on the current transformation matrix."
]

matrix: command [
	"Premultiplies the current transformation matrix with the given block."
	matrix-setup [block!] "content must be 6 numbers"
]

pen: command [
	"Sets the line pen color."
	color [tuple! image! logic!] "Set to OFF to disable pen"
]

polygon: command [
	"Draws a closed area of line segments. First and last points are connected."
	vertices [block!] "Block of pairs"
]

push: command [
	"Stores the current attribute setup in stack."
	draw-block [block!]
]

reset-matrix: command [
	"Resets the current transformation matrix to its default values."
]

rotate: command [
	"Sets the clockwise rotation in current transformation matrix."
	angle [number!] "in degrees"
]

scale: command [
	"Sets the scaling factor in current transformation matrix."
	factor [pair!]
]

shape: command [
	"Draws shapes using the SHAPE sub-dialect."
	commands [block!] "Block of SHAPE sub-commands"
]

skew: command [
	"Sets a coordinate system skewed from the original by the given number of degrees in specified axis."
	angle [pair!] "Positive numbers skew to the right; negative numbers skew to the left."
]

spline: command [
	"Draws a curve through any number of points. The smoothness of the curve will be determined by the segment factor."
	points [block!] "Block of pairs"
	segmentation [integer!]
	'spline-ending [word!] "Leave the spline: OPENED or CLOSED"
]

text: command [
	"Draws a string of text."
	origin [pair!] "offset from where should the text be rendered"
	end [pair! none!] "End point of text box (clips and wraps the text). NONE means no clip/wrap limit within the gob."
	'render-mode [word!] "RASTER or VECTORIAL"
	rich-text-block [block!]
]

transform: command [
	"Applies transformation such as translation, scaling, and rotation."
	angle [number!]
	center [pair!]
	scale [pair!]
	translation [pair!]
]

translate: command [
	"Sets the translation in current transformation matrix."
	offset [pair!]
]

triangle: command [
	"Draws triangular polygon with shading parameters (Gouraud shading). Set colors to NONE to turn of shading."
	vertex-1 [pair!]
	vertex-2 [pair!]
	vertex-3 [pair!]
	color-1 [tuple! none!]
	color-2 [tuple! none!]
	color-3 [tuple! none!]
	dilation [number!] "Useful for eliminating anitaliased edges"
]


 #forecast only ARMA models only
 rm(list=ls())

#function returns only 1 value
pre<-function(post,p,q){
#post-starting value ,p-pvalue

#for all p coeffienct calculation
sham_sunder<-NULL #for adding p coeff
for( rum in seq_along(p)) {
sham_sunder<-sum(sham_sunder,p[rum]*t[post-rum] )  #left term of equation
}   #for 4 p

#for all q coefficient cal
vasant_vruksha<-NULL
for (sari in seq_along(q)){
vasant_vruksha<-sum(vasant_vruksha,q[sari]*t[post-sari])  #right term of equation
}  #for 4 q

z=sham_sunder+t[post]+vasant_vruksha
return(z)
}  #function finish

#opening potential values matrix
v<-read.table("C:\\Users\\msc2\\Desktop\\Halwa\\BADMASHI\\pot_tamasha\\chocolate_potential_x.txt",skip=1)
w<-v[1:20,2:4] #taking only 3 columns & 20 rows (excludes X's row & AA column)

dhino_dhino<-NULL #for appending file_name & r_square
woh_hai<-read.table("C:\\Users\\msc2\\Desktop\\Halwa\\BADMASHI\\Model\\ARMA\\Autofit_arma_stationary_rectified_linux.txt",skip=1)  #all stationary files
kaun_hai<-as.character(woh_hai[,1])  #file names

for ( bari_bari in seq_along(kaun_hai)){

tripyl<-as.character(woh_hai[bari_bari,]$V1)
pyar<-read.table(paste("C:\\kindle_patrika\\PDB\\pdb_MoserFear\\",tripyl,"_phi_psi_pot.pdb",sep=""),skip=1 )  #opening potential file

shukrana<-as.character(pyar$V2)  #original AA seq
fikrana<-pyar$V3  #original AA States
muskurana<-pyar$V4  #original potential values

t<-muskurana
hari_haran<-as.numeric(strsplit(toString(woh_hai[bari_bari,]$V3[1])," ")[[1]])  #p-values      #pal<-jk[[1]][1]
kari_karan<-as.numeric(strsplit(toString(woh_hai[bari_bari,]$V5[1])," ")[[1]])  #q-values     #

#forecasting
sajna<-NULL #for appending forecasted value
sallu<-c(length(hari_haran),length(kari_karan))
shraddha<-which.max(sallu) #stoes length of p
if(shraddha==1){shraddha<-length(hari_haran) }else{shraddha<-length(kari_karan)}  #checking which p/q max

for( phulwa in (shraddha+1):length(t)){
sajna<-append(sajna,pre(phulwa,hari_haran,kari_karan))   #1---> starting vlaue ,2---> p-value
}
sajna<-append(t[1:shraddha],sajna,) #appending remaining element

x<-t   #original value
y<-sajna    #predicted value
f<-lm(y~x)
gen_r_square<-summary(f)$r.squared

#wikipedia method of R-square
r_wiki_square<-1- ( sum((x-y)^2)/ sum((x-mean(x))^2)  )

#for AA & state predictions
motivated<-NULL # for appending AA seq
robotic_vkj<-NULL #for appending states of AA

for( papa in sajna ){
muskurahat=papa     #taking predicted potential value for comparing with matrix
z<-abs(w-muskurahat)==min(abs(w-muskurahat))   #comparing with matrix
great_thumb<-as.character(v[c(which(z[,1]),which(z[,2]),which(z[,3])),]$V1)    #taking single AA character
motivated<-append(motivated,great_thumb)  #appending to predicted AA seq
jannatein<-which(c(length(which(z[,1])),length(which(z[,2])),length(which(z[,3])) )==1)   #gives state of AA
robotic_vkj<-append(robotic_vkj,jannatein)    #appending predicted AA states
}

#Assembling data & writing
sab_kuch<-append(rep(NA,length(t)-1),r_wiki_square,after=0)   #last column
behind<-cbind(t,sajna,sab_kuch,shukrana,motivated,fikrana,robotic_vkj,deparse.level=0)  #written matter for each file (ori_pot,pred_pot,r_sq,ori_AA,pred_AA,ori_states,pred_states)

write.table(behind,paste("C:\\Users\\msc2\\Desktop\\Halwa\\BADMASHI\\forecasting\\ARMA\\forecast_ARMA_stationary\\",tripyl,".txt",sep=""),col.names=c("ori_pot","pred_pot","R_Square","ori_AA","pred_AA","ori_states","pred_states"),row.names=F)
dhino_dhino<-rbind(dhino_dhino,cbind(tripyl,gen_r_square,r_wiki_square,deparse.level=0),deparse.level=0) #file_name,General_R_sq,R_wiki_Sq

} #whole file iterating

#writing info file
write.table(dhino_dhino,"C:\\Users\\msc2\\Desktop\\Halwa\\BADMASHI\\forecasting\\ARMA\\ARMA_forecast_stat_R_sq_info.txt",col.names=c("PDB_id","Gen_R_square","Wiki_R_square"),row.names=F)


# whitinga-selection: whitinga-selection-excellence
# Authors: Amy Marshall, Jason Gush
# whitinga-selection.r 2021-05-03 10:39:21Z

#excellence threshold to be determined by the panel
whitinga_selection_excellence <- function(dataframe, ma = 5, pa = 3, ff = 15, fe = 30, threshold = 3.5){
    # exlude applicants with scores below threshold
    dataframe <- filter(dataframe, Score >= threshold)

    # draw Maori fellows, i.e. Ethnicity is flagged as Maori or Maori/Pacific Nations
    maori_fellows <- dataframe %>% filter(str_detect(Ethnicity, "Ma")) %>% slice_sample(n = ma) %>% mutate(ballot = "M\u101ori")

    # exclude already drawn fellows from the pool
    pool <- dataframe %>% anti_join(maori_fellows, by = c("Gender", "Ethnicity", "id"))

    # draw Pacific Nations fellows, i.e. Ethnicity is flagged as Pacific Nations or Maori/Pacific Nations
    pacific_fellows <- pool %>% filter(str_detect(Ethnicity, "Pa")) %>% slice_sample(n = pa) %>% mutate(ballot = "Pacific")

    fellows <- bind_rows(maori_fellows, pacific_fellows)
    pool <- pool %>% anti_join(fellows, by = c("Gender", "Ethnicity", "id"))

    # determine how many more female fellows are needed
    count_female = fellows %>% filter(Gender == "F") %>% nrow()
    female_fellows_to_select = ff - count_female

    # randomly sort remaining applicant pool
    shuffled_rows <- sample(nrow(pool))
    pool_sorted <- pool[shuffled_rows,]

    # select top sorted female and gender diverse applicants until the minimum target
    # of female fellows  has been drawn
    priv_pool <- pool_sorted %>% filter(Gender == "F" | Gender == "GD")
    head_counter = female_fellows_to_select
    females_drawn = 0

    while (females_drawn < female_fellows_to_select && nrow(fellows) + head_counter < fe) {
        new_fellows <- priv_pool %>% slice_head(n = head_counter) %>% mutate(ballot = "Pool")
        females_drawn <- new_fellows %>% filter(Gender == "F") %>% nrow()
        # if the slice is too small, i.e., as one or more gender diverse fellows were drawn
        # in slice, increase the slice size by one and redraw
        head_counter = head_counter + 1
    }

    fellows <- bind_rows(fellows, new_fellows)

    pool_sorted <- pool_sorted %>% anti_join(new_fellows, by = c("Gender", "Ethnicity", "id"))

    # draw from the top of the sort (now largely/exclusively male or non-reponse) all remaining fellows
    fellows_still_to_draw = fe - nrow(fellows)
    new_new_fellows <- pool_sorted %>% slice_head(n = fellows_still_to_draw) %>% mutate(ballot = "Pool")

    fellows <- bind_rows(fellows, new_new_fellows)
    unchosen_applicant_list <<- pool_sorted %>% anti_join(fellows, by = c("Gender", "Ethnicity", "id"))

    return(fellows)
}


  empirical.ranges = function( db="snowcrab", var, remove.zeros=F, probs=c(0.025, 0.975) ) {
    if (db =="snowcrab") {
      x = snowcrab.db("set.complete")[, var]
      if (remove.zeros) x = x[ which( x>0 ) ]
      return ( quantile( x, probs=probs, na.rm=T ) )
    }
  }


library(data.table)
library(dplyr)

minimum_bin <- function(df_column, minimum=100) {

	if(any(df_column=="", na.rm=TRUE)){
		df_column <- df_column[-which(df_column=="")]
		if(length(df_column) == 0) return(FALSE)
	}

	if(sum(is.na(df_column)) == length(df_column)) return(FALSE)
	result <- table(df_column)

	if(length(result) == 1) {
		# This is the case when everyone is in a single bin.
		return(FALSE)
	} else {
		# Otherwise, ask the size of the smallest bin.
		return(min(result) > minimum)
	}
}

keep_cat_ordered <- function(df_column, minimum=5000) {

	if(any(df_column=="", na.rm=TRUE)){
		df_column <- df_column[-which(df_column=="")]
		if(length(df_column) == 0) return(FALSE)
	}

	if(sum(!is.na(df_column)) >= 5000) {
		return(TRUE)
	} else {
		return(FALSE)
	}
}
get_raw_cts(trybd$f.eid, trybd)
trybd[1:5,1:5]

load("G:/phenotype estimation/F__phenotype estimation_trybd.Rdata")
get_raw_cts <- function(cts_variable, file_header, file=paste0(QCed_input_file_and_output_name , ".tsv"), single=TRUE)
{
	# Get matches in the header file.
	match <- grep(paste0('x', cts_variable, '_'), header)

	if(single) {
		if(length(match)==1) {
			return(match)
		} else {
			return(c())
		}
	} else {
		if(length(match)==1) {
			return(c())
		} else {
			return(match)
		}
	}
}
library(stringr)
colnames(trybd) <- str_extract(colnames(trybd),"[0-9]+")
head(colnames(trybd))
coding_info <- reassign_all_values(colnames(trybd)[-1], variable_info)
reassign_all_values <- function(cts_variables, phenofile) {
	where <- phenofile$FieldID %in% cts_variables
	changes <- cbind(phenofile$FieldID[where], phenofile$DATA_CODING[where])
	changes <- changes[!is.na(changes[,2]),]
	# create a list of variables for each coding
	codings <- list()
	for(i in names(table(changes[,2]))) {
		codings[[i]] <- changes[which(changes[,2]==strtoi(i)),1]
	}
	return(codings)
}

get_reassignment <- function(reassignment) {
	matrix(as.integer(unlist(strsplit(strsplit(reassignment, split='\\|')[[1]], split='='))), ncol=2, byrow=TRUE)
}

make_the_changes <- function(reassignment_matrix, cts_variables, data_frame)
{
	for(i in 1:nrow(reassignment_matrix)) {
		matches <- data_frame[cts_variables] == reassignment_matrix[i,1]
		if(length(matches) > 0)
			data_frame[cts_variables][matches] <- reassignment_matrix[i,2]
	}
	return(data_frame)
}

change_values <- function(codings, data_frame, coding_info_file) {
	# Need to read in the encoding and determine the changes to make
	reassignments <- fread(coding_info_file, sep=',', header=TRUE, data.table=FALSE)
	reassignments <- reassignments[reassignments$dataCode %in% names(codings),]
	reassignment_matrices <- sapply(reassignments$reassignments, get_reassignment)
	names(reassignment_matrices) <- reassignments$dataCode
	codings <- codings[order(names(codings))]
	reassignment_matrices <- reassignment_matrices[order(names(reassignment_matrices))]

	for(i in 1:length(reassignment_matrices)) {
		data_frame <- make_the_changes(reassignment_matrices[[i]], as.character(codings[[i]]), data_frame)
	}

	return(data_frame)
}

### take average for each variables and integrate them together
average_over_cts_multi <- function(cts_variable, data_frame)
{
	where <- grep(cts_variable, names(data_frame))
	column <- rowMeans(data_frame[,where], na.rm=TRUE)
	column[is.nan(column)] <- NA
	return(column)
}

x1807 <- irnt(trybd[,"f.1807.0.0"])
head(x1807)
irnt <- function(cts_variable) {
    set.seed(1234) # This is the same as was used by PHESANT - for checking.
    n_cts <- length(which(!is.na(cts_variable)))
    quantile_cts <- (rank(cts_variable, na.last = "keep", ties.method = "random") - 0.5) / n_cts
    # use the above to check, but also use frank for the real thing
    cts_IRNT <- qnorm(quantile_cts)
    return(cts_IRNT)
}

look_for_logical <- function(column) {
	return("TRUE" %in% column | "FALSE" %in% column)
}


# Licensed under the Apache License, Version 2.0 (the "License");
# you may not use this file except in compliance with the License.
# You may obtain a copy of the License at
#
# http://www.apache.org/licenses/LICENSE-2.0
#
# Unless required by applicable law or agreed to in writing, software
# distributed under the License is distributed on an "AS IS" BASIS,
# WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
# See the License for the specific language governing permissions and
# limitations under the License.

#' To perform GWAS with GLM and MLM model and get the P value of SNPs
#'
#' Build date: Aug 30, 2016
#' Last update: May 25, 2017
#'
#' @author Lilin Yin and Xiaolei Liu
#'
#' @param phe phenotype, n * 2 matrix
#' @param geno Genotype in numeric format, pure 0, 1, 2 matrix; m * n, m is marker size, n is population size
#' @param CV Covariance, design matrix(n * x) for the fixed effects
#' @param cpu number of cpus used for parallel computation
#' @param verbose whether to print detail.
#'
#' @return m * 2 matrix, the first column is the SNP effect, the second column is the P values
#' @export
#'
#' @examples
#' phePath <- system.file("extdata", "07_other", "mvp.phe", package = "rMVP")
#' phenotype <- read.table(phePath, header=TRUE)
#' idx <- !is.na(phenotype[, 2])
#' phenotype <- phenotype[idx, ]
#' print(dim(phenotype))
#' genoPath <- system.file("extdata", "06_mvp-impute", "mvp.imp.geno.desc", package = "rMVP")
#' genotype <- attach.big.matrix(genoPath)
#' genotype <- deepcopy(genotype, cols=idx)
#' print(dim(genotype))
#'
#' glm <- MVP.GLM(phe=phenotype, geno=genotype)
#' str(glm)
MVP.GLM <-
function(
    phe,
    geno,
    CV=NULL,
    cpu=1,
    verbose=TRUE
){

    n <- ncol(geno)
    m <- nrow(geno)
    ys <- as.numeric(as.matrix(phe[,2]))

    if(!is.big.matrix(geno))    stop("genotype should be in 'big.matrix' format.")
    if(sum(is.na(ys)) != 0) stop("NAs are not allowed in phenotype.")
    if(nrow(phe) != ncol(geno)) stop("number of individuals not match in phenotype and genotype.")

    if(is.null(CV)){
        X0 <- matrix(1, n)
    }else{
        CV.index <- apply(CV, 2, function(x) length(table(x)) > 1)
        CV <- CV[, CV.index, drop=FALSE]
        X0 <- cbind(matrix(1, n), CV)
    }
    X0 <- as.matrix(X0)
    iX0X0 <- MASS::ginv(crossprod(X0))

    logging.log("scanning...\n", verbose = verbose)

    mkl_env({
        results <- glm_c(y = ys, X = X0, iXX = iX0X0, geno@address, verbose = verbose, threads = cpu)
    })

    return(results[, c(1, 2, ncol(results))])
}#end of MVP.GLM function


library(venn)

setwd("/media/yuri/Data/home1/GNI_data/infection/ResultsSciRep")
load("CAP_Sepsis_Ensemble_noise_sig.RDat")
load("H1N1_Ensemble_noise_sig.RDat")
load("COVID19_Ensemble_noise.RDat")

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

# Respiratory chain complex I (subcomplex I alpha) is redundant, although gene sets differ slightly
# We choose mitochondrial respiratory chain complex I assembly for the ensemble gene noise for the COVID19 patients
# as it has bigger association with COVID19 mild/sever stage
idx1 <- grep("Respiratory chain complex I (subcomplex I alpha)", rownames(COVID_ENS_noise_sig), fixed = T )
idx2 <- grep("mitochondrial respiratory chain complex I assembly", rownames(COVID_ENS_noise_sig), fixed = T )
COVID_ENS_noise_sig[idx1,] <- COVID_ENS_noise_sig[idx2,]
COVID_ENS_noise_sig <- COVID_ENS_noise_sig[-idx2,]
COVID_ENS_noise_sig$padj <- p.adjust(COVID_ENS_noise_sig$p, "bonferroni")

################################################################################
setwd("/media/yuri/Data/home1/GNI_data/infection/ResultsSciRep/Figures")

pdf("Figure2A.pdf")

venn(list( 'COVID-19' = rownames(COVID_ENS_noise_sig)[COVID_ENS_noise_sig$padj < 0.01],
  H1N1 = rownames(padjR_H1N1_stage_sig_UP),
                CAP = rownames(padjR_CAP_stage_sig_UP),
                sepsis = rownames(padjR_SPS_stage_sig_UP)), ilabels = TRUE, zcolor = "style"
)

dev.off()


# context("plot_LogLike")

# test_that("plotll", {
  set.seed(1)
  dat <- raphylo(20)

  # aphylo method
  expect_true(is.null(plot_logLik(dat)))

  # phylo_mle method
  ans <- suppressWarnings(aphylo_mle(dat ~ mu_d + psi))
  expect_true(is.null(plot_logLik(ans)))

# })


# GetGlitchErrorRates.r

source("../common/DataUtil.r")

# G E T   D A T A
# Get the data into the right form for these plots.
alldat.df <- fndfGetGiantDataRaw("")
newdat <- alldat.df %>%
group_by(copies, lifem
        , auditfrequency, audittype, auditsegments
        , glitchfreq, glitchimpact) %>%
summarize(mdmlosspct=round(midmean(lost/docstotal)*100.0, 2), n=n())

# Params today: quarterly auditing, five copies.
IMPACTLO <- 67
IMPACTHI <- 90
NCOPIES <- 5
results0 <- filter(newdat, glitchimpact==0)
results1 <- filter(newdat, glitchimpact==IMPACTLO)
results2 <- filter(newdat, glitchimpact==IMPACTHI)
results <- rbind(results0, results1, results2)
trows <- filter(results, copies==NCOPIES)

# P L O T   D A T A
library(ggplot2)
source("../common/PlotUtil.r")

gp <- ggplot(data=trows
            , aes(x=lifem,y=safe(mdmlosspct)
            , color=factor(glitchimpact)
#            , shape=factor(copies)
                    )
            )

# Plots
gp <- fnPlotLogScales(gp, x="YES", y="YES"
                ,xbreaks=c(2,5,10,100,1000)
                ,ybreaks=c(0.01,0.10,1.00)
                )
gp <- gp + geom_line(
                  size=3
                , show.legend=TRUE
                )
gp <- gp + geom_point(data=trows
                , size=6
                , show.legend=TRUE
                , color="black"
                )

# Legends
gp <- gp + labs(color="Glitch impacts"
                )
gp <- gp + theme(legend.position=c(0.75,0.7))
gp <- gp + theme(legend.background=element_rect(fill="lightgray",
                                  size=0.5, linetype="solid"))
gp <- gp + theme(legend.key.size=unit(0.3, "in"))
gp <- gp + theme(legend.key.width=unit(0.6, "in"))
gp <- gp + theme(legend.text=element_text(size=16))
gp <- gp + theme(legend.title=element_text(size=14))
gp <- gp + scale_color_discrete(labels=c("none", "moderate", "high"))

# Titles
gp <- fnPlotTitles(gp
            , titleline="Occasional temporary glitches "
                %+% "increase the server error rate for some period, "
                %+% "\nbut otherwise are not substantially different "
                %+% "from normal operation "
                %+% "\n "
                %+% "\n(Total annual auditing, 5 copies, duration = 10 years)"
            , xlabel="1MB sector half-life (megahours)"
                %+% "                           (lower error rate =====>)"
            , ylabel="permanent document losses (%)"
        )

# Limit lines
# Label the percentage lines out on the right side.
xlabelposition <- log10(800)
gp <- fnPlotPercentLine(gp, xloc=xlabelposition)
gp <- fnPlotMilleLine(gp, xloc=xlabelposition)
gp <- fnPlotSubMilleLine(gp, xloc=xlabelposition)

plot(gp)
fnPlotMakeFile(gp, "glitcherrorrates.png")

# Unwind any remaining sink()s to close output files.
while (sink.number() > 0) {sink()}


#Usage:
#Rscript cell_classified_differential.r gene_list gene_class
library("monocle")
library("reshape")
library("ggplot2")
library("pheatmap")
args <- commandArgs(trailingOnly=TRUE)
if(length(args)!=2)
{
	print("Usage: Rscript cell_classified_differential.r gene_list gene_class")
}
HSMM <- readRDS("classified_cells.rds")
gene_list <-  unlist(strsplit(args[1],","))
gene_class <- unlist(strsplit(args[2],","))
saveRDS(gene_list,'gene_list.rds')
saveRDS(gene_class,'gene_class.rds')
newHSMM <- HSMM[gene_list,]
expression_matrix <- exprs(newHSMM)
colnames(expression_matrix) <- pData(newHSMM)$CellType
#sorted_matrix <- expression_matrix[order(gene_class),order(colnames(expression_matrix))]
sorted_matrix <- expression_matrix[,order(colnames(expression_matrix))]
Cell_Type <- colnames(sorted_matrix)
colnames(sorted_matrix) <- 1:length(colnames(sorted_matrix))
annotation_col_data <- data.frame(Cell_Type)
#annotation_row_data <- data.frame(gene_class[order(gene_class)])
annotation_row_data <- data.frame(gene_class)
rownames(annotation_row_data) <- rownames(sorted_matrix)
names(annotation_row_data) <- "Gene Class"
names(annotation_col_data) <- "Cell Type"
log_matrix <- log(sorted_matrix+1)
#png('cell_classified_heatmap.png',width = ceiling(length(rownames(annotation_col_data))*10), height = ceiling(length(rownames(annotation_row_data))*8), units= 'px',res=600)
png('cell_classified_heatmap.png',width = 15, height = 15, units= 'in',res=600)
pheatmap(log_matrix, annotation_col=annotation_col_data,annotation_row=annotation_row_data,cluster_cols = FALSE,cluster_rows = FALSE,show_colnames = FALSE)
dev.off()


##
## Replicating the analyses in Koster & Leckie (2014) - "Food sharing networks in lowland Nicaragua: An application of the social relations model to count data"
## using the R interface to WinBUGS
##
## Author: Matthew Gwynfryn Thomas (@matthewgthomas)
## URL: http://matthewgthomas.co.uk
## Date: 16 April 2015
##
## Before running the code, do these:
## 1. install WinBUGS from: http://www.mrc-bsu.cam.ac.uk/software/bugs/the-bugs-project-winbugs/
##    - install patch for version 1.4.3
##    - load the license key
##
## 2. install the R packages R2WinBUGS and memisc
##
## 3. download the supplementary data files from http://dx.doi.org/10.1016/j.socnet.2014.02.002
##    and unzip them into your R working directory
##
## Note: This code uses a modified version of Koster & Leckie's "model1.txt" model specification.
##   The only difference is that in "model1_mgt.txt" the intercept 'beta' is no longer an array.
##   (The diff in this GitHub project shows the exact change made.)
##
##
## Copyright (c) 2015 Matthew Gwynfryn Thomas
##
## Permission is hereby granted, free of charge, to any person obtaining a copy
## of this software and associated documentation files (the "Software"), to deal
## in the Software without restriction, including without limitation the rights
## to use, copy, modify, merge, publish, distribute, sublicense, and/or sell
## copies of the Software, and to permit persons to whom the Software is
## furnished to do so, subject to the following conditions:
##
## The above copyright notice and this permission notice shall be included in all
## copies or substantial portions of the Software.
##
## THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
## IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
## FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE
## AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
## LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,
## OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE
## SOFTWARE.
## ----------------------------------------------------------------------------

#install.packages("R2WinBUGS", "memisc")
library(R2WinBUGS)
library(memisc)  # for the mtables() model summariser function

# this file contains a summariser function for BUGS social relations models
# see: https://gist.github.com/matthewgthomas/beef5ee7a434d3da934d
source("https://gist.githubusercontent.com/matthewgthomas/beef5ee7a434d3da934d/raw/06fbdc38003b7648b503f7dc0464549e053c84ad/getSummary.bugs.r")

winbugs_dir = "C:/Program Files/WinBUGS14/"  # change this to your WinBUGS directory

###############################################################
## Load and prepare data
##
dyads = read.csv("dyads.csv")
hh = read.csv("households.csv")

# remove "did" (dyad ID) and "hid" (household ID)
dyads$did = NULL
hh$hid = NULL

# convert the dyads and households column names into one list
data = c(as.list(colnames(dyads)), as.list(colnames(hh)))

# add "R_gr" (scale matrix associated with the Wishart prior for the giver-receiver covariance matrix)
data = c(data, "R_gr")

# make R_gr scale matrix
R_gr = matrix(c(1,0,0,1), nrow=2, ncol=2)

# create separate lists in the workspace for each column in the dyads and hh dataframes
## code from: http://stackoverflow.com/questions/16052239/split-a-data-frame-by-columns-and-storing-each-column-as-an-object-with-the-colu
invisible(lapply(names(dyads), function(x) assign(x, dyads[, x], envir = .GlobalEnv)))
invisible(lapply(names(hh), function(x) assign(x, hh[, x], envir = .GlobalEnv)))

# what do we want out of the model?
parameters <- c("beta", "COV_gr", "COV_dd", "gr", "dd", "rho_dd", "sigma_dd", "sigma2_d")

###############################################################
## Model 1
##
data_m1 = data[c(1:5, length(data))]  # keep only hidA, hidB, giftsAB, giftsBA, offset and R_gr

# specify initial values for the model parameters
inits_m1 = function() {
  list (beta = 0,  # only intercept in this model
        TAU_gr = matrix(c(2,0,0,2), nrow=2, ncol=2),  # giver-receiver precision matrix
        tau_d = 1.333,  # relationship precision == relationship variance of 0.75 (1 / tau_d)
        rho_dd = 0.500  # dyadid reciprocity
  )
}

# run the model
model1 = bugs(data_m1, inits_m1, parameters, "model1_mgt.txt",
              n.chains=1, n.burnin=50000, n.iter=100000, n.thin=100,
              debug=F, bugs.directory=winbugs_dir)

###############################################################
## Model 2
##
# specify initial values for the model parameters
inits_m2 = function() {
  list (beta = rep(0, 17),  # 17 coefficients = 0
        TAU_gr = matrix(c(2,0,0,2), nrow=2, ncol=2),  # giver-receiver precision matrix
        tau_d = 1.333,  # relationship precision == relationship variance of 0.75 (1 / tau_d)
        rho_dd = 0.500  # dyadid reciprocity
  )
}

# run the model
model2 = bugs(data, inits_m2, parameters, "model2.txt",
              n.chains=1, n.burnin=50000, n.iter=100000, n.thin=100,
              debug=F, bugs.directory=winbugs_dir)

###############################################################
## Show output of models (Table 2 in Koster & Leckie 2014)
##
plot(model1)
plot(model2)

bugs.summary = mtable("Model 1"=model1, "Model 2"=model2,
                      coef.style="ci.se.horizontal", digits=2)
relabel(bugs.summary,
        "beta[1]"  = "Intercept",
        "beta[2]"  = "Giver – Game",
        "beta[3]"  = "Giver – Fish",
        "beta[4]"  = "Giver – Pigs",
        "beta[5]"  = "Giver – Wealth",
        "beta[6]"  = "Receiver – Game",
        "beta[7]"  = "Receiver – Fish",
        "beta[8]"  = "Receiver – Pigs",
        "beta[9]"  = "Receiver – Wealth",
        "beta[10]" = "Receiver – Pastors",
        "beta[11]" = "Relationship – Relatedness 1",
        "beta[12]" = "Relationship – Relatedness 2",
        "beta[13]" = "Relationship – Relatedness 3",
        "beta[14]" = "Relationship – Relatedness 4",
        "beta[15]" = "Relationship – Distance (log transformed)",
        "beta[16]" = "Relationship – Association index",
        "beta[17]" = "Relationship – Giver 1 & Receiver 25"
        )


# This is a test/example rd file
# Two diffuse spheres, 4 light sources
# Same geometry, but left sphere has shading interpolation,
# Right sphere has no interpolation

Display "Interpolation"  "Screen" "rgbdouble"
Format 640 480
CameraFOV 5
CameraEye 0 0 50

WorldBegin

FarLight 0 0 -1  1.0  1.0  1.0  1.0

FarLight  1  1 -0.5  1.0 0.0 0.0  0.5  #Red Light    -- Lower Left
FarLight  0 -1 -0.5  0.0 1.0 0.0  0.5  #Green Light  -- Up
FarLight -1  1 -0.5  0.0 0.0 1.0  0.5  #Blue Light   -- Lower Right

Ka 0.0
Kd 1.0

Translate -1.25 0 0

Sphere 1.0 -1.0 1.0 360.0

Translate 2.5 0 0

OptionBool "Interpolate" off

Sphere 1.0 -1.0 1.0 360.0

WorldEnd


##Main function of generating random parameter values

RandomGeneration<-function(WD, GD, CropName, CultivarID, GenotypeFileName, ParameterProperty, ParameterAddress, TotalParameterNumber, NumberOfModelRun, RoundOfGLUE, GLUEFlag)
{

Option="U";
#Set uniform distribution as the default distribution to generate the random parameter sets.

if(Option=="U")
{
eval(parse(text = paste("source('",WD,"/Uniform.r')",sep = '')));
RandomParameter<-(Uniform(GD, CropName, CultivarID, GenotypeFileName, ParameterProperty, ParameterAddress, TotalParameterNumber, NumberOfModelRun, RoundOfGLUE, GLUEFlag));
#Get rid of the negative random values through ABS();

}

return(RandomParameter);##Return the generated random matrix.
}


setwd('/Users/Cam/Desktop/ds_practice/jeopardy/')
getwd()
ls()
options(prompt='R> ')
options(continue = '\t')

#save.image('jeopardy_explore')
load('jeopardy_explore')

contestants = read.csv('contestants.csv')
final_results = read.csv('final_results.csv')
locations = read.csv('locations.csv')
questions = read.csv('questions.csv')
trend = read.csv('trend.csv')

#what are we dealing with?
head(contestants)
head(final_results)
head(locations)
head(questions)
head(trend)

#This is Modal Jeopardy! we pit the most typical contestants against one another and ask the most typical jeopardy questions to see who will emerge as our typical champion

########
# contestants - who shall play our game?
########

#most frequent state

#most typical name of a jeopardy player
first_names = sort(table(contestants$player_first_name), decreasing =TRUE)
first_names[1:10]
last_names = sort(table(contestants$player_last_name), decreasing =TRUE)
last_names[1:10]

occupations = sort(table(contestants$occupation), decreasing =TRUE)
occupations[1:10]
#note the last occupation 'the reigning NFL MVP'
#Matt Jennings is the most common player name on jeopardy!
#Ken Jennings == GOAT confirmed, he was 74 of those 86 games
# we need someone different that old Ken Jennings, so lets take the unique ids and find our three most typical players

#redo with only unique player ids

#duplicate players removed
head(contestants)
unique_contestants = contestants[!duplicated(contestants$player_id),]
head(unique_contestants)

#are all the individuals retained?
length(unique(contestants$player_id)) == length(unique_contestants$player_id)

#who is the most typical jeopardy contestant?
u_first_name = sort(table(unique_contestants$player_first_name), decreasing =TRUE)
u_first_name[1:3]
u_last_name = sort(table(unique_contestants$player_last_name), decreasing =TRUE)
u_last_name[1:3]

u_occupations = sort(table(unique_contestants$occupation), decreasing =TRUE)
u_occupations[1:3]

u_locations = sort(table(unique_contestants$hometown_city), decreasing =TRUE)
u_locations[1:3]

#the modal
#So who do we have playing our game of modal jeopardy this evening?

#chair 1. John Johnson # an attorney from Los Angeles
#chair 2. Matt Brown # a senior (college senior in USA is 4th year student, not an old person) from New York
#chair 3. Michael Smith # a graduate student from Washington

#with our new contestants, lets being the contest. Alex would you kindly tell us the categories

#########
# questions - what will the categories be?
#########
head(questions)

#is potent potables really the most used category?
category_freq = sort(table(questions$category), decreasing=TRUE)
#remove final jeopardy from the list

category_freq = category_freq[2:length(category_freq)]
category_freq[1:6]
length(category_freq)
#32000 different categories!
category_freq[1:10]
#most common is before and after with 468

barplot(category_freq[1:101])
barplot(category_freq)

#Our categories, first round:
category_freq[1:6]
#BEFORE & AFTER
#POTPOURRI
#SCIENCE
#AMERICAN HISTORY
#STUPID ANSWERS
#WORD ORIGINS

#Our categories, second round:
category_freq[7:12]
#RHYME TYME
#POP CULTURE
#NONFICTION
#LITERATURE
#AMERICANA
#COLLEGES & UNIVERSITIES

#John Johnson has is our reigning modal champion, so he selects first.

#find the most typical board slections for each clue_picker in the trend df

left_selections = trend[trend$clue_picker == "returning_champ",]
middle_selections = trend[trend$clue_picker == "middle",]
right_selections = trend[trend$clue_picker == "right",]

left_choice_mat  = table(left_selections$row,left_selections$column)
left_choice_mat[] = rank(left_choice_mat)

middle_choice_mat  = table(middle_selections$row,middle_selections$column)
middle_choice_mat[] = rank(middle_choice_mat)

right_choice_mat  = table(right_selections$row,right_selections$column)
right_choice_mat[] = rank(right_choice_mat)

#use this to select the cell to pick, turn to NA once picked
right_choice_mat  == min(right_choice_mat)

#find the most typical correct respondant for each cell on the board in the trend column, use these to get the game scored.
#call a cell, and pick the winner from the list of correct respondants for that cell.
correct_respondant_mat = matrix(data = rep(0, times = 30),5,6)
for(i in 1:5){
	for(j in 1:6){
		selected_row = trend[trend$row == i,]
		selected_cell = selected_row[selected_row$column == j,]
		selected_weighted_prob = sample(selected_cell$correct_respondent,1)
		correct_respondant_mat[i,j] = as.character(selected_weighted_prob)
	}
}

correct_respondant_mat

#build a matrix with the 6 most asked questions for each category, and second matrix with the correct respondant, award the points accordingly

question_board = data.frame(BEFORE_and_AFTER = rep(0, times=6),
							POTPOURRI = rep(0, times=6),
							SCIENCE = rep(0, times=6),
							AMERICAN_HISTORY  =rep(0, times=6),
							STUPID_ANSWERS = rep(0, times=6),
							WORD_ORIGINS = rep(0, times=6))

answer_board = question_board

#pull 6 random questions from that category and add them to the question df
for(col in 1:6){
	name = category_freq[col]
	q_df = questions[questions$category == labels(name),]
	q_to_pick = sample(1:length(q_df$answer),6)
	linear_questions = q_df$question[q_to_pick]
	answers = q_df$answer[q_to_pick]
	question_board[,col] = linear_questions
	answer_board[,col] = answers
}

#build a matrix with the visited cells, and use this for question selection
visited_cells = matrix(data = rep(0, times = 30),5,6)

#walk through the game, giving the points based on the correct answer modes.

#write a function to walk from question to question and then give the points to the players.


#!/usr/bin/env Rscript
source("common.r")
source("wave.r")
source("paddle.r")
source("duckdive.r")

# ------------------------------------------------------------------------------
# Session script.
#
# This script loads up the given panel then waits for commands of actions to
# run against that panel. Each command is given by a JSON object of the format
#
# { "command" : "COMMAND_NAME", "parameters" : {} }
#
# Where parameters is unique to the particular command.
#
# The event finding commands produce output of the following type:

# Besides the event finding commands this script supports the following
# control commands:
#
# - "exit" - exit from the script immediately.
#
# ------------------------------------------------------------------------------

write("Beginning spectral event finding script", stderr())

# Assuming that the parameters come first
f<-file("stdin")
open(f)

write("Reading RowCount",stderr())
rowCount <- readParameters(f)
rowCount <- checkRowCount(rowCount)
# print(parameters$rowCount)

write("Reading panel", stderr())
panel <- readPanel(f,rowCount$rowCount)

while (1) {

    write("Reading Commands",stderr())
    parameters <- readParameters(f)

    #print(parameters$command) # For readability

    if (parameters$command=="exit"){
        write("Received the exit command. Exiting ...",stderr())
        break;
    }
    check <- checkParameters(parameters,rowCount$rowCount)
    if (check == 1) {
        if (parameters$command == "wave") {
            write ("Wave finding ... ",stderr())
            results <- findWave(panel,parameters$parameters)
        } else if (parameters$command =="paddle") {
            write("Paddle finding ... ", stderr())
            results <- findPaddle(panel,parameters$parameters)
        } else if (parameters$command == "duckdive") {
            write("DuckDive Finding ... ",stderr())
            results <- findDuckdive(panel,parameters$parameters)
        }

        results <- list(type=parameters$parameters$eventType,results=results)
        write("Outputing results to STDOUT", stderr())
        cat(toJSON(results),"\n")
    } else {
        printEmpty(parameters$command)
    }
}

Sys.sleep(0.020)
quit(status=0)


Cory Williams
Programmer Script
Project 4
R-verion 3.6.0

#loading necessary downstream packages
library(dplyr)
library(Seurat)
library(patchwork)

#all packages and scripts were obtained from the publishing website and ran in an interactive R-studio envrironment
provided by BU clustering computing network

#assigns the location of the alevin output file to a variable to be called on
files <- "/projectnb/bf528/users/group_8/project_4/programmer/GSM2230760__salmon_quant/alevin/quants_mat.gz"

#loads the package needed to import alevin data
library("tximport", lib.loc="~/R/x86_64-pc-linux-gnu-library/3.6")

#uses txiport to import alevin file ad txi variable
txi <- tximport(files, type="alevin")

#crearting Seurat object using txi$counts which is the cell count and assinging it to vairable "pbmc"
pbmc <- CreateSeuratObject(counts = txi$counts , min.cells = 3, min.features = 200, project = "10X_PBMC")

#plot initial numbers of cell count and gene expression count per cell pre filtering and noramlization
VlnPlot(pbmc, features = c("nFeature_RNA", "nCount_RNA"), ncol = 3

#filtering out genes higher than 200 but lower than 2500 and applying it to
pbmc <- subset(pbmc, subset = nFeature_RNA > 200 & nFeature_RNA < 2500 & percent.mt < 5)

#normalize data
pbmc <- NormalizeData(pbmc, normalization.method = "LogNormalize", scale.factor = 10000)

#account for variation
pbmc <- FindVariableFeatures(pbmc, selection.method = "vst", nfeatures = 2000)

#set a standard for gene variation
all.genes <- rownames(pbmc)
pbmc <- ScaleData(pbmc, features = all.genes)

#cluster cells
pbmc <- FindNeighbors(pbmc, dims = 1:10)
pbmc <- FindClusters(pbmc, resolution = 0.5)