#Scenario_baseline

####
# Country parameters
countryiso3 = 'MOZ' # ISO3
national_official_population = 30400000 # number of people # REF:
national_official_elrate = 0.31 # national electricity access rate
national_official_population_without_access = national_official_population- (national_official_population*national_official_elrate) # number of people without access

# Planning horizon parameters
today = 2020
planning_year = 2030
planning_horizon = planning_year - today

# Pump technical parameters
rho = 1000 # density of water (1000 kg / m3)
g = 9.81 # gravitational constant (m / s2)
c = 3.6 * (10^6) # differential pressure, (Pa)

#Threshold parameters
threshold_surfacewater_distance = 5000 # (m): distance threshold which discriminates if groundwater pumping is necessary or a surface pump is enough # REF:
threshold_groundwater_pumping = 15 # (m): maximum depth at which the model allows for water pumping: beyond it, no chance to install the pump # REF:

# Energy efficiency improvement factors
eff_impr_rur1= 0.05
eff_impr_rur2= 0.075
eff_impr_rur3= 0.1
eff_impr_rur4= 0.125
eff_impr_rur5= 0.15

eff_impr_urb1= 0.05
eff_impr_urb2= 0.075
eff_impr_urb3= 0.1
eff_impr_urb4= 0.125
eff_impr_urb5= 0.15

#number of hours of pumping, 3 during the morning and 3 during the evening
nhours_irr = 6
eta_pump = 0.75

discount_rate = 0.15 #

# Transportation costs
fuel_consumption = 15 # (l/h) # REF: OnSSET
fuel_cost = 1 # (USD/l) # baseline, then adapted based on distance to city
truck_bearing_t = 15 # (tons) # REF: https://en.wikipedia.org/wiki/Dump_truck

#Pumo economic parameters
LCOE_for_pumping = 0.08 # USD/kWh # REF:
lifetimepump = 30

# import local crop prices csv.  Structure: X, Y, City, cropname1, cropname 2, ...
#prices = readxl::read_xlsx(paste0(input_folder , "prices.xls"))

# Appliances cost, household (check ./ramp/ramp/RAMP_households/Appliances cost.xlsx for inputs)
rur1_app_cost=154
rur2_app_cost=171
rur3_app_cost=278
rur4_app_cost=958
rur5_app_cost=1905

urb1_app_cost=113
urb2_app_cost=307
urb3_app_cost=902
urb4_app_cost=1464
urb5_app_cost=2994

# Appliances cost, schools (check ./ramp/ramp/RAMP_social/Appliances_schools.xlsx for inputs)
sch_1_app_cost = 60
sch_2_app_cost = 360
sch_3_app_cost = 1590
sch_4_app_cost = 2550
sch_5_app_cost = 3220

# Appliances cost, healtchare  (check ./ramp/ramp/RAMP_social/Appliances_healthcare.xlsx for inputs)
hc_1_app_cost = 110
hc_2_app_cost = 4710
hc_3_app_cost = 95060
hc_4_app_cost = 305660
hc_5_app_cost = 611450

#

########
# Define main input files #

# Country and provinces shapefiles
gadm0 = read_sf("D:/OneDrive - FONDAZIONE ENI ENRICO MATTEI/Current papers/Prod_Uses_Agriculture/Applications/GISele_MLED_link/mozambique/Namajavira_4326.shp")

# Population (Default dataset used: HRSL, 30m)
population = raster("D:/OneDrive - FONDAZIONE ENI ENRICO MATTEI/Current papers/Prod_Uses_Agriculture/Applications/GISele_MLED_link/mozambique/population_moz_2019-07-01.tif")

# Import cropland extent (Default dataset used: GFSAD30CE)
cropland_extent = raster("D:/OneDrive - FONDAZIONE ENI ENRICO MATTEI/Current papers/Prod_Uses_Agriculture/Applications/GISele_MLED_link/mozambique/GFSAD30AFCE_2015_S20E30_001_2017261090100.tif")

# Import climatezones (Default datasets used: GAEZ soil classes)
climatezones = raster(paste0(input_folder , 'GAEZ_climatezones.tif'))

# Import surface water basins layer (Default datasets used: Global Surface Water Explorer)
categories_surface_water = raster(paste0(input_folder , 'transitions.tif'))

# Import diesel price layer (In each pixel: 2015 prices baseline , cost per transporting it from large cities)
diesel_price = raster(paste0(input_folder , 'diesel_price_baseline_countryspecific.tif'))

#
crops = readxl::read_xlsx(paste0(input_folder , 'crops_cfs_ndays_months.xlsx'))

# Define extent of country analysed
ext = extent(gadm0)

#source(noaccesspopulation.R)

clusters = read_sf("D:/OneDrive - FONDAZIONE ENI ENRICO MATTEI/Current papers/Prod_Uses_Agriculture/Applications/GISele_MLED_link/mozambique/Namajavira_clusters.shp")

#clusters = read_sf("D:/OneDrive - FONDAZIONE ENI ENRICO MATTEI/Current papers/Prod_Uses_Agriculture/Manuscript/First paper/Revision_1/mg_sites_2_5km.gpkg")

popnoaccess2018 = raster(paste0(processed_folder , 'noaccess/pop18_noaccess_kenya.tif'))
population = raster("D:/OneDrive - FONDAZIONE ENI ENRICO MATTEI/Current papers/Prod_Uses_Agriculture/Applications/GISele_MLED_link/mozambique/population_moz_2019-07-01.tif")

clusters$pop <- exactextractr::exact_extract(population, clusters, fun="sum")
clusters$noacc <- exactextractr::exact_extract(popnoaccess2018, clusters, fun="sum")

# adjust
somma = sum(clusters$pop)
spread = ((national_official_population-somma)/somma)

print(spread)

clusters$pop <- clusters$pop * 1+spread

somma = sum(clusters$noacc)
spread = (((national_official_population*(1-national_official_elrate))-somma)/somma)

print(spread)

clusters$noacc <- clusters$noacc * 1+spread

clusters$elrate <- 1- (clusters$noacc/clusters$pop)


R

library(sf)
library(terra)

# get OSM data located in my cloud service
temp <- tempfile()
download.file("https://filedn.com/l4iF16owVCHBm81sGhdrcpX/raw_data/hotosm_arg_roads_lines_shp.zip", temp)
utils::unzip(temp, exdir = "raw_data/.")
unlink(temp)

arg_road <- st_read("raw_data/hotosm_arg_roads_lines_shp/hotosm_arg_roads_lines.shp")
arg_road_2 <- arg_road[arg_road$highway %in% c("motorway", "motorway_link",
                                "trunk",  "primary", "secondary",
                                "tertiary", "residential", "road",
                                "unclassified"), ]
rm(list="arg_road"); gc()

dir.create("src/arg_road_aoi")

aoi_r <- rast("src/classified_aoi_subset.tif")
aoi_bbox_sf <- st_as_sf(as.polygons(ext(aoi_r)))
st_crs(aoi_bbox_sf) <- 4326

arg_road_logi <- st_intersects(arg_road_2, aoi_bbox_sf)
arg_road_aoi <- st_crop(arg_road_2[lengths(arg_road_logi) > 0, ], aoi_bbox_sf)

plot(aoi_r)
plot(st_geometry(arg_road_aoi), col = 'magenta', add = TRUE)

road_r <- terra::rasterize(
    vect(as(arg_road_aoi, "Spatial")),
    aoi_r,
    field = NULL,
    fun = "last",
    background = NA_real_,
    by = NULL)

st_write(arg_road_aoi, "src/arg_road_aoi/arg_road_aoi.shp")

writeRaster(road_r,
    filename = file.path("src","arg_road_aoi", "road_r.tif"),
    overwrite = TRUE)

# for GRASS installed on Windows using the OSGEO4W64 installation https://grass.osgeo.org/download/windows/
# Other installation might work out of the box. On Mac and Linux systems...(to be tested.)
# Note: the grass_setup.R should be verified for version and the paths.
source("R/grass_setup.R")

this_wd <- getwd()
temp_dir <- tempdir()

grassdata_path <- temp_dir
data_path <- file.path(this_wd, "src", "arg_road_aoi")
inp_path <- file.path(data_path, "road_r.tif")
out_path <- file.path(data_path, "road_r_distance.tif")

# create a location so you can start with grass tasks
loc <- rgrass7::initGRASS(
    gisBase = grass.gis.base,
    gisDbase = grassdata_path,
    mapset = "PERMANENT",
    override = TRUE)

execGRASS("g.proj", flags = "c", parameters = list(georef = inp_path))
execGRASS("r.in.gdal", flags = c("overwrite"), input = inp_path, output = "road_raster")

execGRASS("g.region", flags = "c", parameters = list(raster = "road_raster"))
execGRASS("g.region", flags = "p")
execGRASS("g.proj", flags = "p")

execGRASS("r.grow.distance", flags = "m", parameters = list(input = "road_raster", distance = "road_distance", metric = "geodesic"))
execGRASS("r.out.gdal", flags = "overwrite", parameters = list(input = "road_distance", output = out_path))

dist_rast <- rast(out_path)
dist_rast <- round(dist_rast)

writeRaster(dist_rast, filename = out_path, overwrite = TRUE, datatype = "INTU2")

# clean
unlink(grassdata_path, recursive = TRUE)
plot(dist_rast)


#' Takes a numeric vector and maps it into a finite length sequence
#' @param x A numeric or integer vector.
#' @param nlevels Integer scalar. Length of the sequence to be map onto.
#' @param as_factor Logical scalar. When \code{TRUE} the resulting vector is factor.
#' @return A vector of length \code{length(x)} with values mapped to a sequence
#' with \code{nlevels} unique valuess
#' @export
#' @examples
#'
#' x <- rnorm(100)
#' w <- data.frame(as.integer(round_to_seq(x, as_factor = TRUE)),x)
#' plot(w,x)
#'
#' @seealso Used in \code{\link{diffmap}} and \code{\link{plot_diffnet2}}
round_to_seq <- function(x, nlevels=20, as_factor=FALSE) {
  y <- range(x, na.rm = TRUE, finite=TRUE)
  y <- seq(y[1], y[2], length.out = nlevels)

  y <- sapply(x, function(z) {
    if (is.na(z)) return(NA)
    y[which.min(abs(y-z))]
    })
  # factor(c(1,3), levels = 1:3, labels = letters[1:3])
  if (as_factor) as.factor(y)
  else y
}

#' Another way of visualizing diffusion
#' @templateVar toa TRUE
#' @templateVar slice TRUE
#' @template graph_template
#' @template plotting_template
#' @param pers Integer vector of length \eqn{T} indicating the time periods of the data.
#' @param color.ramp A function as returned by \code{\link[grDevices:colorRamp]{colorRamp}}.
#' @param layout Passed to \code{\link[igraph:plot.igraph]{plot.igraph}}.
#' @param key.width Numeric scalar. Sets the proportion of the plot (x-axis) that the key uses.
#' @param key.args List. Further arguments to be passed to \code{\link{drawColorKey}}.
#' @param main Character scalar. Title of the graph.
#' @param add.map Character scalar. When \code{"first"} plots a \code{\link{diffusionMap}} before the
#'  graph itself. If \code{"last"} then it adds it at the end. When \code{NULL} adds nothing.
#' @param diffmap.args List. If \code{add.map=TRUE}, arguments passed to \code{diffusionMap}.
#' @param diffmap.alpha Numeric scalar between [0,1]. Alpha level for the map.
#' @param include.white Character scalar. Includes white in the color palette used in the map.
#'  When \code{include.white=NULL} then it won't include it.
#' @param ... Further arguments passed to \code{\link[igraph:plot.igraph]{plot.igraph}}.
#' @param no.graph Logical scala. When \code{TRUE} the graph is not drawn. This only makes
#' sense when the option \code{add.map} is active.
#' @details If \code{key.width<=0} then no key is created.
#'
#' By defult, the function passes the following values to \code{plot.igraph}:
#'
#' \itemize{
#' \item{\code{vertex.label} equals to \code{""}}
#' \item{\code{vertex.frame.color} equals to \code{"white"}}
#' \item{\code{add} equals to \code{TRUE}}
#' \item{\code{rescale} equals to \code{FALSE}}
#' \item{\code{vertex.size} equals to \code{rescale.fun(vertex.size)}}
#' }
#'
#' @return A list with the following elements
#' \item{layout}{A numeric matrix with vertex coordinates.}
#' \item{vertex.color}{A character vector with computed colors for each vertex.}
#' \item{vertex.label}{The value passed to \code{plot_diffnet2}.}
#' \item{vertex.shape}{A character vector with assigned shapes.}
#' \item{vertex.size}{A numeric vector with vertices sizes}
#' \item{diffmap}{If \code{add.map=TRUE}, the returned values from \code{\link{diffmap}}}
#' @export
#' @family visualizations
#' @author George G. Vega Yon
plot_diffnet2 <- function(graph, ...) UseMethod("plot_diffnet2")

#' @rdname plot_diffnet2
#' @export
#' @include diffnet-methods.r data.r
plot_diffnet2.diffnet <- function(
  graph,
  toa,
  slice = nslices(graph),
  ...
) {

  if (missing(toa))
    toa <- graph$toa

  plot_diffnet2.default(
    graph         = graph$graph[[slice]],
    toa           = toa,
    pers          = graph$meta$pers,
    ...)
}

#' @rdname plot_diffnet2
#' @export
plot_diffnet2.default <- function(
  graph,
  toa,
  pers          = min(toa, na.rm = TRUE):max(toa, na.rm = TRUE),
  color.ramp    = grDevices::colorRamp(viridisLite::magma(20)),
  layout        = NULL,
  key.width     = 0.1,
  key.args      = list(),
  main          = "Diffusion dynamics",
  add.map       = NULL,
  diffmap.args  = list(kde2d.args=list(n=100)),
  diffmap.alpha = .5,
  include.white = "first",
  vertex.size   = "degree",
  minmax.relative.size = getOption("diffnet.minmax.relative.size", c(0.01, 0.04)),
  no.graph      = FALSE,
  ...) {

  # Modifying some arguments
  oldpar <- graphics::par(no.readonly = TRUE)
  on.exit(graphics::par(oldpar))
  par(xpd = NA)

  # Collecting arguments
  igraph.args <- list(...)

  # Some constants
  nper <- length(pers)

  if (length(add.map) && !(add.map %in% c("first", "last")))
    stop("When -add.map- is specified it should be either \'first\' or \'last\'.")

  if (!length(add.map) & no.graph)
    stop("If -no.graph=TRUE- then you should specify some value for -add.map-.")

  # Taggin types ---------------------------------------------------------------

  # 1st adopters
  type_1st <- toa == pers[nper]

  # Non Adopters
  type_non <- is.na(toa)

  # Adopters
  type_adopt <- which(!type_1st & !type_non)
  type_1st   <- which(type_1st)
  type_non   <- which(type_non)

  # Colors
  t01 <- pers
  t01 <- c(t01[1], t01[nper])
  col <- color.ramp( (toa - t01[1])/(t01[2] - t01[1]) )

  # Adding alpha
  if (ncol(col) < 4)
    col <- cbind(col, 255)

  col[type_non,] <- 255

  col <- rgb(col[,1], col[,2], col[,3], col[,4], maxColorValue = 255)

  # Shapes
  if (!no.graph && !length(igraph.args$vertex.shape)) {
    igraph.args$vertex.shape <- rep("circle", nnodes(graph))
    igraph.args$vertex.shape[type_non] <- "square"
  }

  # Adjmat must have dimnames to make sure sorting in igraph is fine
  add_dimnames.mat(graph)

  # Computing positions
  g <- igraph::graph_from_adjacency_matrix(graph, weighted = TRUE)

  igraph.args$layout <- if (!length(layout)) igraph::layout_nicely(g)
  else if (inherits(layout, "function")) layout(g)
  else layout

  # Adjusting layout
  igraph.args$layout <- igraph::norm_coords(igraph.args$layout)

  # Keywidth
  key.width <- max(0, key.width)

  graphics::plot.new()
  graphics::plot.window(xlim=c(-1,1 + 5*key.width), ylim=c(-1,1))
  graphics::title(main=main)

  # If adding map! -------------------------------------------------------------
  if (length(add.map)) {

    dm <- do.call(diffusionMap.default, c(diffmap.args, list(graph=graph, x=toa,
                                                             layout = igraph.args$layout)))
    # Levels
    dmlvls <- pretty(range(dm$map$z), diffmap.args$kde2d.args$n)

    # Colors, in this case we need to extrapolate nper and add white.
    dmcol <- grDevices::rgb(color.ramp(seq(0,1, length.out = nper*2)), maxColorValue = 255)

    # Do we need to include white in the map?
    if (length(include.white))
      if (include.white=="first") dmcol <- c("white", dmcol)
      else if (include.white=="last") dmcol <- c(dmcol, "white")
      else stop('-include.white- should be either NULL, "first" or "last".')

    # Palette
    dmcol <- grDevices::adjustcolor(grDevices::colorRampPalette(dmcol)(length(dmlvls)),
                                    alpha.f=diffmap.alpha)

    # Plot
    if (add.map=="first")
      graphics::.filled.contour(dm$map$x, dm$map$y, dm$map$z, levels = dmlvls, col=dmcol)
  } else dm <- NULL

  # Plotting graph -------------------------------------------------------------

  # Setting up parameters
  set_igraph_plotting_defaults("igraph.args")

  igraph.args$vertex.size <- rescale_vertex_igraph(
    compute_vertex_size(g, vertex.size),
    minmax.relative.size = minmax.relative.size
    )

  igraph.args$vertex.color <- col

  # Calling igraph
  if (!no.graph)
    do.call(
      what = igraph::plot.igraph,
      args = c(list(g),igraph.args)
    )

  if (length(add.map) && (add.map=="last"))
      graphics::.filled.contour(dm$map$x, dm$map$y, dm$map$z, levels = dmlvls, col=dmcol)

  # # Plotting boxes -------------------------------------------------------------
  if (key.width > 0) {
    # Adjusting the color
    color.palette <- color.ramp(c(0,.5,1))

    if (ncol(color.palette) < 4)
      color.palette <- cbind(color.palette, 255)

    color.palette <- grDevices::rgb(
      color.palette[,1], color.palette[,2], color.palette[,3],
      color.palette[,4],
      maxColorValue = 255)

    color.palette <- grDevices::colorRampPalette(color.palette, TRUE)

    # Filling missings
    if (!length(key.args$main))   key.args$main <- "Time of Adoption"
    if (!length(key.args$na.col)) key.args$na.col <- "transparent"
    if (!length(key.args$na.lab)) key.args$na.lab <- "Non-adopters"
    if (!length(key.args$border)) key.args$border <- "transparent"
    if (!length(key.args$tick.marks)) {
      toaran <- range(toa, na.rm=TRUE)
      key.args$tick.marks <-
        unique(floor(seq(toaran[1], toaran[2], length.out = 5)))
    }

    do.call(
      what = drawColorKey,
      args = c(
        list(toa, key.pos = c(1-key.width, 0.975, 0.05, 0.95), nlevels = 100,
             color.palette = color.palette(100)),
        key.args
      )
    )
  }

  invisible(list(
    layout       = igraph.args$layout,
    vertex.color = col,
    vertex.size  = igraph.args$vertex.size,
    vertex.shape = igraph.args$vertex.shape,
    diffmap      = dm)
    )
}

#' Creates a heatmap based on a graph layout and a vertex attribute
#'
#' Using bi-dimensional kernel smoothers, creates a heatmap based on a graph layout
#' and colored accordingly to \code{x}. This visualization technique is intended
#' to be used with large graphs.
#'
#' @param graph A square matrix of size \eqn{n\times n}{n * n}.
#' @param slice Integer scalar. Slice of the network to be used as baseline for drawing the graph.
#' @param x An vector of length \eqn{n}. Usually a \code{toa} vector.
#' @param layout Either a \eqn{n\times 2}{n *2} matrix of coordinates or a layout
#'  function applied to \code{graph} (must return coordinates).
#' @param jitter.args A list including arguments to be passed to \code{\link{jitter}}.
#' @param kde2d.args A list including arguments to be passed to \code{\link[MASS:kde2d]{kde2d}}.
#' @param sharp.criter A function choose whether to apply a weighted mean for each cell,
#' or randomize over the values present in that cell (see details).
#' @param ... Arguments passed to method.
#' @details
#' The image is created using the function \code{kde2d} from
#' the \pkg{MASS} package. The complete algorithm follows:
#' \enumerate{
#'  \item \code{x} is coerced into integer and the range is adjusted to start from 1.
#'    \code{NA} are replaced by zero.
#'  \item If no \code{layout} is passed, layout is computed using
#'    \code{\link[igraph:layout_nicely]{layout_nicely}} from \pkg{igraph}
#'  \item Then, a \code{kde2d} map is computed for each level of \code{x}. The
#'    resulting matrices are added up as a weighted sum. This only holds if
#'    at the cell level the function \code{sharp.criter} returns \code{FALSE}.
#'  \item The jitter function is applied to the repeated coordinates.
#'  \item 2D kernel is computed using \code{kde2d} over the coordinates.
#' }
#'
#' The function \code{sharp.criter} must take two values, a vector of levels and a
#' vector of weights. It must return a logical scalar with value equal to \code{TRUE}
#' when a randomization at the cell level must be done, in which case the final
#' value of the cell is chosen using \code{sample(x, 1, prob=w)}.
#'
#' The resulting matrix can be passed to \code{\link{image}} or similar.
#'
#' The argument \code{x.adj} uses by default the function \code{\link{round_to_seq}}
#' which basically maps \code{x} to a fix length sequence of numbers such that
#' \code{x.adj(x)} resembles an integer sequence.
#'
#' @return A list of class \code{diffnet_diffmap}
#' \item{coords}{A matrix of size \eqn{n\times 2}{n*2} of vertices coordinates.}
#' \item{map}{Output from \code{kde2d}. This is a list with 3 elements, vectors
#'  \code{x}, \code{y} and matrix \code{z} of size \eqn{n\times n}{n*n} (passed
#'  via \code{kde2d.args}).}
#' \item{h}{Bandwidth passed to \code{kde2d}.}
#' @export
#' @family visualizations
#' @references Vega Yon, George G., and Valente, Thomas W., Visualizing Large Annotated
#' Networks as Heatmaps using Weighted Averages based on Kernel Smoothers (Working paper).
#' @author George G. Vega Yon
#' @examples
#'
#' # Example with a random graph --------------------------------------------------
#'
#' set.seed(1231)
#'
#' # Random scale-free diffusion network
#' x <- rdiffnet(500, 4, seed.graph="scale-free", seed.p.adopt = .025,
#'                            rewire = FALSE, seed.nodes = "central",
#'                            rgraph.arg=list(self=FALSE, m=4),
#'                            threshold.dist = function(id) runif(1,.2,.4))
#'
#' # Diffusion map (no random toa)
#' dm0 <- diffusionMap(x, kde2d.args=list(n=150, h=.5), layout=igraph::layout_with_fr)
#'
#' # Random
#' diffnet.toa(x) <- sample(x$toa, size = nnodes(x))
#'
#' # Diffusion map (random toa)
#' dm1 <- diffusionMap(x, layout = dm0$coords, kde2d.args=list(n=150, h=.5))
#'
#' oldpar <- par(no.readonly = TRUE)
#' col <- colorRampPalette(blues9)(100)
#' par(mfrow=c(1,2), oma=c(1,0,0,0))
#' image(dm0, col=col, main="Non-random Times of Adoption\nAdoption from the core.")
#' image(dm1, col=col, main="Random Times of Adoption")
#' par(mfrow=c(1,1))
#' mtext("Both networks have the same distribution on times of adoption", 1,
#'       outer = TRUE)
#' par(oldpar)
#'
#' # Example with Brazilian Farmers --------------------------------------------
#' dn <- brfarmersDiffNet
#'
#' # Setting last TOA as NA
#' diffnet.toa(dn)[dn$toa == max(dn$toa)] <-
#'   NA
#'
#' # Coordinates
#' coords <- sna::gplot.layout.fruchtermanreingold(
#'   as.matrix(dn$graph[[1]]), layout.par=NULL
#' )
#'
#' # Plotting diffusion
#' plot_diffnet2(dn, layout=coords, vertex.size = 300)
#'
#' # Adding diffusion map
#' out <- diffusionMap(dn, layout=coords, kde2d.args=list(n=100, h=50))
#' col <- adjustcolor(colorRampPalette(c("white","lightblue", "yellow", "red"))(100),.5)
#' with(out$map, .filled.contour(x,y,z,pretty(range(z), 100),col))
#'
diffusionMap <- function(graph, ...) UseMethod("diffusionMap")

#' @export
#' @rdname diffusionMap
diffmap <- diffusionMap

#' Computes weighted variance
#' @param x A numeric vector of length \eqn{n}.
#' @param w A numeric vector of length \eqn{n}.
#' @details \code{weighted_variance} implements weighted variance computation
#' in the following form:
#' \deqn{%
#' \frac{\sum_i w_i'(x_i - \bar x)^2}{(1-n)}
#' }{%
#' sum[w(i)'(x(i) - w.mean(x))^2/(1-n)]
#' }
#'
#' where \eqn{w_i'=w_i/\sum_i w_i}{w(i)' = w(i)/sum(w)}, and
#' \eqn{\bar x = \sum_i w_i'x_i}{w.mean(x)=sum[w(i)'*x(i)]}.
#' @return Numeric scalar with the weighted variance.
#' @export
#' @seealso This function is used in \code{\link{diffmap}}.
weighted_var <- function(x,w) {
  n <- length(x)
  w <- w/sum(w, na.rm=TRUE)*n
  m <- sum(x*w/sum(w, na.rm=TRUE), na.rm=TRUE)
  sum((x - m)^2*w/(n-1+1e-15), na.rm=TRUE)
}

#' @export
#' @rdname weighted_var
wvar <- weighted_var

#' @export
#' @param x.adj Function to adjust \code{x}. If not \code{NULL} then it is applied
#'  to \code{x} at the beginning (see details).
#' @rdname diffusionMap
diffusionMap.default <- function(
  graph, x, x.adj=round_to_seq, layout=NULL,
  jitter.args = list(),
  kde2d.args  = list(n=100),
  sharp.criter=function(x, w) {
    wvar(x,w) > (max(x, na.rm=TRUE) - min(x, na.rm=TRUE))^2/12
    },...) {

  # Step 0) Preparing the data
  if (length(x.adj)) {
    if (!is.function(x.adj)) stop('-x.adj- must be a function')
    x <- x.adj(x)
  }

  # Adjmat must have dimnames to make sure sorting in igraph is fine
  if (!length(unlist(dimnames(graph), recursive = TRUE)))
    dimnames(graph) <- list(1:nnodes(graph), 1:nnodes(graph))

  # Computing positions
  g <- igraph::graph_from_adjacency_matrix(graph, weighted = TRUE)

  coords <- if (is.function(layout)) layout(g)
  else if (!length(layout)) igraph::layout_nicely(g)
  else if (is.matrix(layout)) layout

  # Step 1) Compute densities per level
  if (!length(kde2d.args$h))
    kde2d.args$h <- c(MASS::bandwidth.nrd(coords[,1]), MASS::bandwidth.nrd(coords[,2]))

  # Mapping limits
  lims   <- c(range(coords[,1]), range(coords[,2]))
  lvls   <- unique(x)
  nlvls  <- length(unique(x))
  Maps   <- with(kde2d.args, list(z=array(0, dim=c(n,n,nlvls) )))
  Maps$W <- Maps$z
  for (i in 1:nlvls) {
    # Skip if NA
    if (is.na(lvls[i])) next

    # Subset and map
    dat <- coords[which(x==lvls[i]),,drop=FALSE]
    map <- do.call(MASS::kde2d, c(kde2d.args, list(
      x = dat[,1], y=dat[,2], lims=lims)))

    # Adding up (for weighted average)
    Maps$W[,,i] <- map$z
    Maps$z[,,i] <- map$z*lvls[i]

  }

  # Processing each level
  Map     <- with(kde2d.args, list(z=matrix(0, ncol=n, nrow=n)))
  Map$W   <- Map$z

  for (i in 1:kde2d.args$n)
    for (j in 1:kde2d.args$n) {

      # Computing variance at that level
      if (sharp.criter(lvls,Maps$W[i,j,]) || sum(Maps$W[i,j,]) < 1e-30 ) {
        Map$z[i,j] <- sum(Maps$z[i,j,])/(sum(Maps$W[i,j,]) + 1e-15)
      } else {
        Map$z[i,j] <- sample(lvls, 1, prob=Maps$W[i,j,])
      }
    }

  # Normalizing
  # Map$z <- Map$z/(Map$W + 1e-15)
  Map$x <- seq(lims[1], lims[2], length.out = kde2d.args$n)
  Map$y <- seq(lims[3], lims[4], length.out = kde2d.args$n)

  structure(list(
    coords = coords,
    map    = with(Map, list(x=x,y=y,z=z)),
    h       = kde2d.args$h,
    used_x  = x
  ), class="diffnet_diffmap")
}

#' @rdname diffusionMap
#' @export
diffusionMap.diffnet <- function(graph, slice=nslices(graph), ...) {
  with(graph, diffusionMap.default(graph[[slice]], toa, ...))
}

#' @rdname diffusionMap
#' @export
image.diffnet_diffmap <- function(x, ...) {
  graphics::image(x$map,...)
}

#' @rdname diffusionMap
#' @export
print.diffnet_diffmap <- function(x, ...) {
  cat("An object of class -diffnet_map-\n")
  cat(utils::str(x))
  cat("Use methods -plot- and -image-.")
}

#' @rdname diffusionMap
#' @param y Ignored.
#' @export
plot.diffnet_diffmap <- function(x, y=NULL, ...) {
  image.diffnet_diffmap(x, ...)
}


install.packages("ggcorrplot")
install.packages("MASS")
install.packages("keras")
install.packages("NeuralNetTools")
install.packages("kableExtra")
install.packages("fpc")
install.packages("psych")
install.packages("Hmisc")
install.packages("cluster")
install.packages("mclust")
install.packages("factoextra")


PATH <- '00_data/babies-stoerche.csv'

JAHR <- c(1965, 1971, 1974, 1977, 1978, 1979, 1980)
BABIES <- c(1061, 788, 631, 583, 577, 580, 654)
STOERCHE <- c(1910, 1295, 1071, 904, 1019, 974, 910)

TAB <- cbind(JAHR, BABIES, STOERCHE)
DF <- data.frame(TAB)
#DF <- data.frame(JAHR, BABIES, STOERCHE)
str(DF)
summary(DF)

write.table(DF, PATH, quote = FALSE, sep = ',', row.names = FALSE)

DF2 <- read.csv(PATH)
str(DF2)
summary(DF2)


###############################################################################
# This program is free software: you can redistribute it and/or modify
# it under the terms of the GNU General Public License as published by
# the Free Software Foundation, either version 3 of the License, or
# (at your option) any later version.
#
# This program is distributed in the hope that it will be useful,
# but WITHOUT ANY WARRANTY; without even the implied warranty of
# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
# GNU General Public License for more details.
#
# You should have received a copy of the GNU General Public License
# along with this program.  If not, see <http://www.gnu.org/licenses/>.
###############################################################################
# Collection of Utilities to Biuld and Analyze Multiple Factor Model
# Copyright (C) 2012  Michael Kapler
#
# For more information please visit my blog at www.SystematicInvestor.wordpress.com
# or drop me a line at TheSystematicInvestor at gmail
###############################################################################

###############################################################################
# Count Consecutive Changes
#' @export
###############################################################################
consecutive.changes <- function
(
	data, 		# data series
	positive=T	# count positive consecutive changes
)
{
	if(positive) dir = diff(data) > 0 else dir = diff(data) < 0

	temp = cumsum(iif(dir, 1, 0))
	temp - ifna.prev(iif(dir, NA, coredata(temp)))
}

###############################################################################
# Create plot of factors average correlations and returns
###############################################################################
# http://stackoverflow.com/questions/4310727/what-is-rs-multidimensional-equivalent-of-rbind-and-cbind
# apply(temp, 3, rbind)
# http://r.789695.n4.nabble.com/Collapse-an-array-td850008.html
#' @export
factor.avgcor <- function(data, next.month.ret, name) {
	load.packages('abind')
	# create matrix
	temp = abind(data, along = 3)
		temp = abind(next.month.ret, temp, along = 3)
		dimnames(temp)[[3]][1] = 'Ret'

	# plot
	temp = t(compute.avgcor(temp, 'spearman')[,-1])
		temp[] = plota.format(100 * temp, 0, '', '%')
		plot.table(temp, smain=paste(name,'Correlation',sep=' \n '))
}

###############################################################################
# Compute average correlations
#' @export
###############################################################################
compute.avgcor <- function
(
	data, 		# matrix with data: [rows,cols,factors]
	method = c('pearson', 'kendall', 'spearman')
)
{
	nr = dim(data)[1]
	nc = dim(data)[3]
	corm = matrix(NA,nc,nc)
		colnames(corm) = rownames(corm) = dimnames(data)[[3]]

	for( i in 1:(nc-1) ) {
		for( j in (i+1):nc ) {
			corm[i,j] = mean( as.double( sapply(1:nr, function(t)
				try(cor(data[t,,i], data[t,,j], use = 'complete.obs', method[1]),TRUE)
				)), na.rm=T)
		}
	}
	return(corm)
}

###############################################################################
# Compute Market Cap weighted mean
#' @export
###############################################################################
cap.weighted.mean <- function
(
	data, 	# factor
	capitalization	# market capitalization
)
{
	capitalization = capitalization * (!is.na(data))
	weight = capitalization / rowSums(capitalization,na.rm=T)
	rowSums(data * weight,na.rm=T)
}

###############################################################################
# Compute factor mean for each sector
#' @export
###############################################################################
sector.mean <- function
(
	data, 	# factor
	sectors	# sectors
)
{
	out = data * NA
	for(sector in levels(sectors)) {
		index = (sector == sectors)
		out[,index] = ifna(apply(data[,index, drop=F], 1, mean, na.rm=T),NA)
	}
	return(out)
}

###############################################################################
# Create quantiles
# http://en.wikipedia.org/wiki/Quantile
# rank each month stocks according to E/P factor
# create quantiles, and record their performance next month
#' @export
###############################################################################
compute.quantiles <- function
(
	data, 			# factor
	next.month.ret, # future returns
	smain='', 		# title for plot
	n.quantiles=5, 	# number of quantiles
	plot=T			# flag to create plot
)
{
	n = ncol(data)
	nperiods = nrow(data)

	data = coredata(ifna(data,NA))
	next.month.ret = coredata(ifna(next.month.ret,NA))

	temp = matrix(NA, nperiods, n.quantiles)
	hist.factor.quantiles = hist.ret.quantiles = temp

	temp = matrix(NA, nperiods, n)
	quantiles = weights = ranking = temp

	#index = which(rowSums(!is.na(data * next.month.ret)) > n/2)
	#index = which(rowSums(!is.na(data)) > n/2)
	index = which(rowSums(!is.na(data)) >= n.quantiles)
	for(t in index) {
		factor = data[t,]
		ret = next.month.ret[t,]

		ranking[t,] = rank(factor, na.last = 'keep','first')
		t.ranking = ceiling(n.quantiles * ranking[t,] / count(factor))

		quantiles[t,] = t.ranking
		weights[t,] = 1/tapply(rep(1,n), t.ranking, sum)[t.ranking]

		hist.factor.quantiles[t,] = tapply(factor, t.ranking, mean)
		hist.ret.quantiles[t,] = tapply(ret, t.ranking, mean)
	}

	# create plot
	if(plot) {
		par(mar=c(4,4,2,1))
		temp = 100*apply(hist.ret.quantiles,2,mean,na.rm=T)
 		barplot(temp, names.arg=paste(1:n.quantiles), ylab='%',
 			main=paste(smain, ', spread =',round(temp[n.quantiles]-temp[1],2), '%'))
 	}

 	return(list(quantiles=quantiles, weights=weights, ranking=ranking,
 		hist.factor.quantiles = hist.factor.quantiles, hist.ret.quantiles = hist.ret.quantiles))
}

###############################################################################
# Create Average factor
#' @export
###############################################################################
add.avg.factor <- function
(
	data	# factors
)
{
	# compute the overall factor
	temp = abind(data, along = 3)
	data$AVG = data[[1]]
	data$AVG[] = ifna(apply(temp, c(1,2), mean, na.rm=T),NA)
	return(data)
}

###############################################################################
# Convert factor to Z scores, normalize using market capitalization average
#' @export
###############################################################################
normalize.mkval <- function
(
	data,	# factors
	MKVAL	# capitalization
)
{
	# normalize (convert to z scores) cross sectionaly all factors
	for(i in names(data)) {
		#data[[i]] = (data[[i]] - apply(data[[i]], 1, mean, na.rm=T)) / apply(data[[i]], 1, sd, na.rm=T)
		data[[i]] = (data[[i]] - cap.weighted.mean(data[[i]], MKVAL)) /
							apply(data[[i]], 1, sd, na.rm=T)
	}
	return(data)
}

###############################################################################
# Convert factor to Z scores, only keep the ranks
#' @export
###############################################################################
normal.transform <- function(data)
{
	rk=rank(data, na.last='keep', ties.method = 'first')
	n = count(data)
	x = qnorm((1:n) / (n+1))
	return(x[rk])
}

#' @export
normalize.normal <- function
(
	data	# factors
)
{
	# normalize (convert to z scores) cross sectionaly all factors
	for(i in names(data)) {
		data[[i]][] = t(apply(data[[i]], 1, normal.transform))
	}
	return(data)
}

###############################################################################
# Plot Quantiles
#' @export
###############################################################################
plot.quantiles <- function
(
	data, 			# factors
	next.month.ret, # future one month returns
	smain=''		# title
)
{
	layout(matrix(1:(2*ceiling(len(data)/2)), nc=2))
	sapply(1:len(data), function(i)
		compute.quantiles(data[[i]], next.month.ret, paste(names(data)[i],smain))
	)
}

###############################################################################
# Plot Backtest Quantiles and spread (Q5-Q1)
#' @export
###############################################################################
plot.bt.quantiles <- function
(
	factors,		# factors
	next.month.ret, # future one month returns
	smain='',		# title
	data		 	# data
)
{
	out = compute.quantiles(factors, next.month.ret, plot=F)

	prices = data$prices
		prices = bt.apply.matrix(prices, function(x) ifna.prev(x))

	# find month ends
	month.ends = endpoints(prices, 'months')

	# create strategies that invest in each qutile
	models = list()

	for(i in 1:5) {
		data$weight[] = NA
			data$weight[month.ends,] = iif(out$quantiles == i, out$weights, 0)
			capital = 100000
			data$weight[] = (capital / prices) * (data$weight)
		models[[paste('Q',i,sep='')]] = bt.run(data, type='share', capital=capital)
	}

	# spread
	data$weight[] = NA
		data$weight[month.ends,] = iif(out$quantiles == 5, out$weights,
									iif(out$quantiles == 1, -out$weights, 0))
		capital = 100000
		data$weight[] = (capital / prices) * (data$weight)
	models$Q5_Q1 = bt.run(data, type='share', capital=capital)

	#*****************************************************************
	# Create Report
	#******************************************************************
	plotbt(models, plotX = T, log = 'y', LeftMargin = 3, main=smain)
		mtext('Cumulative Performance', side = 2, line = 1)
}

###############################################################################
# Plot Factors details
#' @export
###############################################################################
plot.factors <- function
(
	data, 			# factors
	name, 			# name of factor group
	next.month.ret	# future one month returns
)
{
	x = as.vector(t(data))
	y = as.vector(t(next.month.ret))
		x = ifna(x,NA)
		y = ifna(y,NA)
		index = !is.na(x) & !is.na(y)
		x = x[index]
		y = y[index]

	cor.p = round(100*cor(x, y, use = 'complete.obs', method = 'pearson'),1)
	cor.s = round(100*cor(x, y, use = 'complete.obs', method = 'spearman'),1)

	# Plot
	layout(1:2)
	plot(x, pch=20)

	par(mar=c(4,4,2,1))
	plot(x, y, pch=20, xlab=name, ylab='Next Month Return')
		abline(lm(y ~ x), col='blue', lwd=2)
		plota.legend(paste('Pearson =',cor.p,',Spearman =', cor.s))
}


library(data.table)
library(stringr)

SAMPLERDIRS <- c("mala", "smmala_reverse", "amsmmala", "alsmmala")

DATADIR <- "../../data"
OUTDIR <- "../output"

nsamplerdirs <- length(SAMPLERDIRS)

nchains <- 10
nmcmc <- 110000
nburnin <- 10000
npostburnin <- nmcmc-nburnin

nmeans <- 50000
ci <- 3
pi <- 7

submeans <- matrix(data=NA, nrow=nmeans, ncol=nsamplerdirs)

for (j in 1:nsamplerdirs) {
  chains <- t(fread(
    file.path(DATADIR, SAMPLERDIRS[j], paste("chain", str_pad(ci, 2, pad="0"), ".csv", sep="")), sep=",", header=FALSE
  ))

  for (i in 1:nmeans) {
    submeans[i, j] <- mean(chains[1:i, pi])
  }
}

cols <- c("green", "blue", "red", "orange")

pdf(file=file.path(OUTDIR, "tdist_meanplot.pdf"), width=10, height=6)

plot(
  1:nmeans,
  submeans[, 1],
  type="l",
  ylim=c(-1., 1.5),
  col=cols[1],
  lwd=2,
  xlab="",
  ylab="",
  cex.axis=1.8,
  cex.lab=1.7,
  yaxt="n"
)

axis(
  2,
  at=c(-1, -0.5, 0, 0.5, 1, 1.5),
  labels=c(-1, -0.5, 0, 0.5, 1, 1.5),
  cex.axis=1.8,
  las=1
)

lines(
  1:nmeans,
  submeans[, 2],
  type="l",
  col=cols[2],
  lwd=2
)

lines(
  1:nmeans,
  submeans[, 3],
  type="l",
  col=cols[3],
  lwd=2
)

lines(
  1:nmeans,
  submeans[, 4],
  type="l",
  col=cols[4],
  lwd=2
)

legend(
  35000, 1.5,
  c("MALA", "SMMALA", "AMSMMALA", "ALSMMALA"),
  lty=c(1, 1, 1),
  lwd=c(5, 5, 5),
  col=cols,
  cex=1.5,
  bty="n",
  text.width=4000
)

dev.off()


#' Plot SSB at age
#'
#' Plots both estimated SSB and proportions as stacked barplot.
#' @param asap name of the variable that read in the asap.rdat file
#' @param save.plots save individual plots
#' @param od output directory for plots and csv files
#' @param plotf type of plot to save
#' @param liz.palette color definitions
#' @export

PlotSSBatAge <- function(asap,save.plots,od,plotf,liz.palette){

  par(mfrow=c(1,1) )

  years<-  seq(asap$parms$styr, asap$parms$endyr)
  ssb.aa.1 <- asap$N.age*exp(asap$options$frac.yr.spawn*(-asap$F.age-asap$M.age))
  if (asap$options$isfecund == 1){
    ssb.aa <- ssb.aa.1*asap$maturity
  }else{
    ssb.aa <- ssb.aa.1*asap$maturity*asap$WAA.mats$WAA.ssb #ssb at age
  }
  ssb.max=max(apply(ssb.aa,1,sum))

  barplot( t(ssb.aa), beside=F  ,  cex.names=0.75 ,
           width=1, space=rep(0,(asap$parms$nyears)),
           xlab = 'Year', ylab ='ASAP Estimated SSB.AA', ylim = c(0,1.15*ssb.max),
           xlim=c(0.5,asap$parms$nyears+1-0.5), col=liz.palette[1:asap$parms$nages] )

  legend('top', horiz=T, legend=seq(1, asap$parms$nages),
         pch=15, col=liz.palette[1:asap$parms$nages], cex=0.8 )

  if (save.plots==T) savePlot(paste0(od, 'SSB.AA.barplot.stacked.', plotf), type=plotf)

  #----same information, but proportion at age each year
  barplot( t(ssb.aa/apply(ssb.aa,1,sum)), beside=F  ,  cex.names=0.75 ,
           width=1, space=rep(0,(asap$parms$nyears)),
           xlab = 'Year', ylab ='ASAP Estimated Proportion (SSB.AA)', ylim = c(0,1.1),
           xlim=c(0.5,asap$parms$nyears+1-0.5), col=liz.palette[1:asap$parms$nages] )

  legend('top', horiz=T, legend=seq(1, asap$parms$nages),
         pch=15, col=liz.palette[1:asap$parms$nages], cex=0.8 )

  if (save.plots==T) savePlot(paste0(od, 'SSB.AA.proportion.barplot.stacked.', plotf), type=plotf)

  return()
}  #end funciton


install.packages("arules")
library(arules)
install.packages("readxl")
library(readxl)

mydata <- read.csv('C:\\Users\\user\\Desktop\\EXCELR ASSIGNMENT\\ASSIGNMENT\\assignment9_association\\my_movies.csv',1)
View(mydata)
ruless1=mydata[,1:5]
ruless2=mydata[,6:15]
View(ruless1)
View(ruless2)

rules22 <- apriori(as.matrix(ruless2),parameter=list(support=0.02,confidence=0.7,minlen=1))
inspect(rules22)
inspect(sort(rules22, by="lift"))
inspect(head(sort(rules22,by="lift")))

# Different Ways of Visualizing Rules
install.packages("arulesViz")
library(arulesViz)
plot(rules22)
plot(rules22,method="grouped")
plot(rules22[1:30],method = "graph") # for good visualization try plotting only few rules

#different support and confidence levels plotted

rules21 <- apriori(as.matrix(ruless2),parameter=list(support=0.002,confidence=0.5,minlen=1))
inspect(rules21)
inspect(sort(rules21, by="lift"))
inspect(head(sort(rules21,by="lift")))

# Different Ways of Visualizing Rules
plot(rules21)
plot(rules21,method="grouped")
plot(rules21[1:30],method = "graph")

#different support and confidence levels plotted
rules23 <- apriori(as.matrix(ruless2),parameter=list(support=0.003,confidence=0.4,minlen=1))
inspect(rules23)
inspect(sort(rules23, by="lift"))
inspect(head(sort(rules23,by="lift")))

# Different Ways of Visualizing Rules
plot(rules23)
plot(rules23,method="grouped")
plot(rules23[1:30],method = "graph")


# ------------encode utf-8-------------------
#datetime: 20210419
#author: Sean Peldom Zhang
#R.version()=4.0.4
# ---------------Practice(1)-----------------
# set workspace
Exp5path="D:/Remain/9.R/EXP/chapter5"
if(getwd()!=Exp5path)setwd(Exp5path)
# process data
load("diabetes.RData")
Male_GLU=subset(dat,dat$Sex=="Male")$GLU
Female_GLU=subset(dat,dat$Sex=="Female")$GLU
if(var(Male_GLU)!=var(Female_GLU)){
  print("Different variance of GLU between Male and Female!")
  boxplot(Male_GLU, Female_GLU, names=c("Male_GLU","Female_GLU"))
  t.test(Male_GLU, Female_GLU,var.equal = FALSE)
}
# ---------------Practice(2)-----------------

# load data from Exp4.r
rm(list = ls(all = TRUE))
if(!requireNamespace("openxlsx",quietly = TRUE))
  install.packages("openxlsx")
library(openxlsx)
ADproteomic=read.xlsx("D:/Remain/9.R/EXP/chapter2/data/ADproteomic.xlsx")
library(stringr)
# detect disease
patstr="(?<=\\.)[a-z]+(?=[0-9]+)"
disease_names=str_extract(names(ADproteomic),pattern = patstr)

# detect strange names I don't know
doknstr="[A-Za-z]+(?=\\.)"
dokn_names=str_extract(names(ADproteomic),pattern = doknstr)

# detect H7BXI1's row location
judgeACTB=str_extract(ADproteomic$Protein.IDs,"H7BXI1")
for(ACTBnum in 1:nrow(ADproteomic)){
  if(!is.na(judgeACTB[ACTBnum]))break
}

# fill data for df_disease
df_disease=as.data.frame(matrix(nrow=length(ADrownams)-1,ncol=3))
colnames(df_disease)=c("Expressions","Disease","Don't known")
ADrownams=names(ADproteomic)
for(i in 2:length(ADrownams)){
  if(ADproteomic[[ADrownams[i]]][ACTBnum]==0){
    df_disease$Expressions[i-1]=NA
  }else{
    df_disease$Expressions[i-1]=log10(ADproteomic[[ADrownams[i]]][ACTBnum])
  }
  df_disease$Disease[i-1]=disease_names[i]
  df_disease$Dontknown[i-1]=dokn_names[i]
}

t.test(df_disease$Expressions[df_disease$Disease=="ctl" & df_disease$Dontknown=="Intensity"],
       df_disease$Expressions[df_disease$Disease=="ad" & df_disease$Dontknown=="Intensity"])
# ---------------Practice(3)-----------------
rm(list = ls(all = TRUE))
load("D:/Remain/9.R/EXP/chapter5/diabetes.RData")
aov(GLU~Sex, dat)

# ---------------Homework(1)-----------------
# load data
rm(list = ls(all = TRUE))
if(!requireNamespace("openxlsx",quietly = TRUE))
  install.packages("openxlsx")
library(openxlsx)
library(stringr)
ADproteomic=read.xlsx("D:/Remain/9.R/EXP/chapter2/data/ADproteomic.xlsx")
ADrownams=names(ADproteomic)
# filter data
ad_subset=subset(ADproteomic, select=na.omit(str_extract(ADrownams,".*LFQ.*ad.*")))
ctl_subset=subset(ADproteomic, select=na.omit(str_extract(ADrownams,".*LFQ.*ctl.*")))
judge_3NA=function(x){return (colSums(as.matrix(x) !=0)>3)}# x is a row
del_judge=apply(ad_subset, 1, judge_3NA)&apply(ctl_subset, 1, judge_3NA)
ADrownams_del=ADproteomic$Protein.IDs[del_judge]
ad_rm_3NA=ad_subset[del_judge,]
ad_rm_3NA[ad_rm_3NA==0]=NA
ctl_rm_3NA=ctl_subset[del_judge,]
ctl_rm_3NA[ctl_rm_3NA==0]=NA
# t test for each protein
p_list=c()
for(i in 1:nrow(ad_rm_3NA)){
    p_list=append(p_list,t.test(ad_rm_3NA[i,],ctl_rm_3NA[i,],var.equal = FALSE)$p.value)
}
result=data.frame(ProteinID = ADrownams_del, 'p-value' = p_list)
# primary abandoned
# for(i in 1:nrow(ADproteomic)){
#   if(rowSums(as.matrix(ad_subset[i,]) == 0)<3){
#     del_judge[i]=TRUE
#     next
#   }else if(rowSums(as.matrix(ctl_subset[i,]) == 0)<3){
#     del_judge[i]=TRUE
#     next
#   }
# }


library(raster)
kamp_dem_sm = readRDS(system.file("testdata/kamp_dem_sm.rds", package="watershed"))

test_that("Fill DEM", {
	skip_on_cran()
	expect_error(filled <- fill_dem(kamp_dem_sm), regex=NA)
	expect_gt(sum(filled[]), sum(kamp_dem_sm[]))
})


#author: Grzegorz Protaziuk, Robert Bembenik
# script EDAMI lab4 2020l
#1. Data reading and analysis
#2. Frequent sequences discovery
#3. Sequential rules discovery

#setting working directory - adjust a path to your directory with a dataset

#setwd('/home/staff/gprotazi/edami2020l');
setwd('~/Desktop/Projects/data_mining/labs/4')

#install.packages("arules")
#install.packages("arulesSequences")

library(arules)
library(arulesSequences)

#read data with sequences - tags assigned by users to items
download.file('http://staff.ii.pw.edu.pl/~gprotazi/dydaktyka/dane/tags.data', 'tags.data')

?read_baskets
dataSeq <- read_baskets(con = file("tags.data", "r"), info = c("sequenceID","eventID","SIZE"))

#summary
summary(dataSeq)
str(dataSeq)

#presenting data in data.frame form
frameS =   as(dataSeq,"data.frame")
View(frameS)

#information about data concerning times
?timeFrequency
timeSeq  = as(dataSeq,"timedsequences")
freqT = timeFrequency(timeSeq, "times")
freqT

spanT= timeFrequency(timeSeq, "span")
spanT

#calculation of frequency of items
?itemFrequency
freqItem = itemFrequency(dataSeq)
#str(freqItem)
freqItem = sort(freqItem, decreasing = TRUE )

head(freqItem,20)
str(dataSeq)

#transaction for in a given sequence
trans109 <- dataSeq[dataSeq@itemsetInfo$sequenceID == 109]
inspect(trans109)

#frequent sequences discovery
#parameters of Spade algorithm
?'SPparameter-class'
seqParam = new ("SPparameter",support = 0.003, maxsize = 5, mingap=1, maxgap = 3, maxlen = 5)
print(seqParam)

#execution of the algorithm
?cspade
patSeq= cspade(dataSeq,seqParam, control = list(verbose = TRUE, tidLists = FALSE, summary= TRUE))

#information about discoverd sequences
summary(patSeq)
#length(patSeq)

inspect(head(patSeq,100))
#patterns with more than one element
seq2elem <- patSeq[size(patSeq)>1]
length(seq2elem)
inspect(seq2elem)

#patters supported by a given sequence of transactions(without time constraints))
inspect(patSeq[which(support(patSeq,trans109,type='absolute') >0)])

#searching for patterns with given items
?subset
?match

seqI = subset(patSeq, x %ein% c('design','art'))
inspect(seqI)
View(as(seqI,"data.frame"))

#execution the algorithm with different parameters
seqParam1 = new ("SPparameter",support = 0.001, maxsize = 5, mingap=1, maxgap = 3, maxlen = 5)
patSeq1= cspade(dataSeq,seqParam1, control = list(verbose = TRUE, tidLists = TRUE, summary= TRUE))

#selecting new discovered sequences

seqdiff = patSeq1[which(!(patSeq1 %in% patSeq))]
length(patSeq1)
length(seqdiff)

#discovery sequential rules
?ruleInduction
seqRules = ruleInduction(patSeq1,confidence = 0.8)

length(seqRules)
#summary of set of rules
summary(seqRules)
#view of rules and sequneces
inspect(seqRules)

?arulesSequences::size

size(lhs(seqRules))
size(lhs(seqRules), 'length')
size(lhs(seqRules), 'itemsets')
size(lhs(seqRules), 'items')

#sequences in the left part of rules
inspect(lhs(seqRules))
#sequences in the right part of rules
inspect(rhs(seqRules))

#items in rules
seqRules@elements@items@itemInfo

#all patterns included in rules (from left and right parts of rules)
allSeq <- c(rhs(seqRules),lhs(seqRules))
allSeq <- unique(allSeq)
inspect(allSeq)
str(allSeq)

#selecting interesting rules
rulesI = subset(seqRules, rhs(seqRules) %in% c('design','webdesign'))
inspect(rulesI)
View(as(rulesI,"data.frame"))

rulesI = subset(seqRules, lhs(seqRules) %ein% c('design','webdesign'))
inspect(rulesI)

rulesI = subset(seqRules, lhs(seqRules) %ein% c('design','webdesign') & rhs(seqRules) %in% c('webdesign'))
inspect(rulesI)

##################################
# Laboratory task
##################################

download.file('http://staff.ii.pw.edu.pl/~gprotazi/dydaktyka/dane/diab_trans.data','diab_trans.data')
#reading data - into dataframe
diab.df <- read.csv("diab_trans.data", header=TRUE, stringsAsFactors = FALSE)
View(diab.df)

#example of saving data into a file  - removing the header line
write.table(diab.df, "diab_trans2.data", sep = "," , row.names = FALSE, col.names = FALSE )

#reading data in transactional form
diabSeq <- read_baskets(con = "diab_trans2.data", sep =",", info = c("sequenceID","eventID"))
View(as(diabSeq,"data.frame"))

summary(diabSeq)

#setting parameters
#time(eventid) in the diab_trans.data set is given as a number of seconds from some date.
#the following values of parameters are the example of values which allow obtaining any sequential rules.

seqParam = new ("SPparameter",support = 0.5, maxsize = 4, mingap=600, maxgap =172800, maxlen = 3 )
patSeq= cspade(diabSeq,seqParam, control = list(verbose = TRUE, tidLists = FALSE, summary= TRUE))

#discovery of sequential rules
seqRules = ruleInduction(patSeq,confidence = 0.8)

length(seqRules)
#summary for the set of rules
summary(seqRules)
#view of of rules
inspect(head(seqRules,100))


#!/usr/bin/env Rscript
setwd("~/Research/datastructures-for-metaprogramming/hamt-heterogeneous/data")

library(reshape2)

# benchmark_fileName <- "map_sizes_heterogeneous_exponential"
benchmark_fileName <- "map_sizes_heterogeneous_exponential_32bit_primitive_latest"
benchmark_data <- read.csv(paste0(benchmark_fileName, ".csv"), sep=",", header=TRUE)

# benchmark_data <- subset(benchmark_data, className != "TrieMapIntInt")

benchmark_data.m <- melt(benchmark_data, id.vars=c('elementCount', 'className'), measure.vars=c('footprintInBytes'))
benchmark_data.c <- dcast(benchmark_data.m,  className ~ elementCount, median, fill=0)

# http://r.789695.n4.nabble.com/Is-there-any-R-function-for-data-normalization-td4644768.html
# http://stackoverflow.com/questions/5294955/how-to-scale-down-a-range-of-numbers-with-a-known-min-and-max-value
# http://math.stackexchange.com/questions/362918/value-range-of-normalization-methods-min-max-z-score-decimal-scaling
normalize <- function(x) {
  x <- sweep(x, 2, apply(x, 2, min))
  sweep(x, 2, apply(x, 2, max), "/")
}

ratio <- function(x) {
  x_min <- apply(x, 2, min)
  sweep(x, 2, x_min, "/")
}

result_fileName <- paste0(benchmark_fileName, "_result.csv")
write.csv2(benchmark_data.c, file = result_fileName, quote = FALSE)

benchmark_data.c.transposed <- data.frame(t(benchmark_data.c[-1]))
colnames(benchmark_data.c.transposed) <-  benchmark_data.c[,1]

resultTransposed_fileName <- paste0(benchmark_fileName, "_result.transposed.csv")
write.csv2(benchmark_data.c.transposed, file = resultTransposed_fileName, quote = FALSE)

benchmark_data.c.ratio <- benchmark_data.c
benchmark_data.c.ratio[-1] <- ratio(benchmark_data.c[-1])

resultRatio_fileName <- paste0(benchmark_fileName, "_result.ratio.csv")
write.csv2(benchmark_data.c.ratio, file = resultRatio_fileName, quote = FALSE)

benchmark_data.c.ratio.transposed <- data.frame(t(benchmark_data.c.ratio[-1]))
colnames(benchmark_data.c.ratio.transposed) <-  benchmark_data.c[,1]

resultRatioTransposed_fileName <- paste0(benchmark_fileName, "_result.ratio.transposed.csv")
write.csv2(benchmark_data.c.ratio.transposed, file = resultRatioTransposed_fileName, quote = FALSE)

benchmark_data.c.norm <- benchmark_data.c
benchmark_data.c.norm[-1] <- normalize(benchmark_data.c[-1])

resultNorm_fileName <- paste0(benchmark_fileName, "_result.norm.csv")
write.csv2(benchmark_data.c.norm, file = resultNorm_fileName, quote = FALSE)

tmp <- data.frame(t(benchmark_data.c.norm[-1]))
colnames(tmp) <- benchmark_data.c.norm[,1]

resultNormTransposed_fileName <- paste0(benchmark_fileName, "_result.norm.transposed.csv")
write.csv2(tmp, file = resultNormTransposed_fileName, quote = FALSE)


# Copyright 2019 Esri

# 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.

Orange$Tree <- as.numeric(Orange$Tree)
ntrees <- max(Orange$Tree)

xrange <- range(Orange$age)
yrange <- range(Orange$circumference)

plot(xrange, yrange, type="n", xlab="Age (days)",
   ylab="Circumference (mm)" )
colors <- rainbow(ntrees)
linetype <- c(1:ntrees)
plotchar <- seq(18,18+ntrees,1)

for (i in 1:ntrees) {
  tree <- subset(Orange, Tree==i)
  lines(tree$age, tree$circumference, type="b", lwd=1.5,
    lty=linetype[i], col=colors[i], pch=plotchar[i])
}

title("Tree Growth")

legend(xrange[1], yrange[2], 1:ntrees, cex=0.8, col=colors,
   pch=plotchar, lty=linetype, title="Tree")


#Look at data for relevant features and missing data

train=read.csv('train.csv',header=T)
dim(train)
[1] 891  12
names(train)
[1] "PassengerId" "Survived"    "Pclass"      "Name"        "Sex"
 [6] "Age"         "SibSp"       "Parch"       "Ticket"      "Fare"
[11] "Cabin"       "Embarked"
str(train)

#Copy original data and change Pclass and Surivived to factor
train1=train
train1$Pclass=as.factor(train1$Pclass)
train1$Survived=as.factor(train1$Survived)

#Some data in Age is missing
sum(is.na(train1$Age))
[1] 177
train2=train1[complete.cases(train1$Age),]
dim(train2)
[1] 714  12
dim(train1)
[1] 891  12

#Plot Age vs surivived,in barplot and density plot
#Conclude Age is relevant in predicting survival
library(ggplot2)
ggplot(train2,aes(x=Age,fill=Survived))+geom_bar(binwidth=0.5,position='dodge')
ggplot(train2,aes(x=Age,fill=Survived))+geom_density(alpha=0.2)

#Plot Pclass vs survived
#Conclude Pclass is relevant in predicting survival.Pclass=1 or 2 survived more than Pclass=3.
sum(is.na(train1$Pclass))
[1] 0
ggplot(train1,aes(x=Pclass,fill=Survived))+geom_bar(binwidth=0.5,position='dodge')

#Plot Sex vs Survived
#Conclude Sex is relevant in predicting survival.Female survived more than male.
sum(is.na(train1$Sex))
[1] 0
ggplot(train1,aes(x=Sex,fill=Survived))+geom_bar(binwidth=0.5,position='dodge')

#Explore SibSp vs Survived with ggplot,table,and barplot
#Conclude SibSp is relevant in predicting survival.Having 1 or 2 SibSp improved survival. Having >2SibSp, especially>4SibSp, decreased chance of survival.
sum(is.na(train1$SibSp))
[1] 0
ggplot(train1,aes(x=SibSp,fill=Survived))+geom_bar(binwidth=0.5)
#Low end of the barplot has few data points. Use table and barplot to have a better look.
table(train1$SibSp,train1$Survived)

      0   1
  0 398 210
  1  97 112
  2  15  13
  3  12   4
  4  15   3
  5   5   0
  8   7   0
barplot(prop.table(table(train1$Survived,train1$SibSp),2))

#Do the same for Parch
#Conclude Parch is relevant for predicting survial,in a similar trend as SibSp.Having 1 or 2 Parch improved survival. Having >3Parch decreased chance of survival.
sum(is.na(train1$Parch))
[1] 0
ggplot(train1,aes(x=Parch,fill=Survived))+geom_bar(binwidth=0.5)
table(train1$Parch,train1$Survived)

      0   1
  0 445 233
  1  53  65
  2  40  40
  3   2   3
  4   4   0
  5   4   1
  6   1   0
barplot(prop.table(table(train1$Survived,train1$Parch),2))

#Plot Fare vs Survived
#Conclude that Fare is relevant to survival.Higher fare improved survival.
sum(is.na(train1$Fare))
[1] 0
ggplot(train1,aes(x=Fare,fill=Survived))+geom_bar()
ggplot(train1,aes(x=Fare,fill=Survived))+geom_density(alpha=0.5)
#To have a better look at fare<100, where most data points concentrate
ggplot(train1[train1$Fare<100,],aes(x=Fare,fill=Survived))+geom_bar()
ggplot(train1[train1$Fare<100,],aes(x=Fare,fill=Survived))+ geom_density(alpha=0.5)

#Both "Ticket" and "Cabin" have too many levels. I didn't include them as relevant features.

#Use table and plot to look at "Embark".Conclude it is relevant.
#Notice there are four levels of factors, with one empty level.
sum(is.na(train1$Embark))
[1] 0
table(train1$Embark,train1$Survived)

      0   1
      0   2
  C  75  93
  Q  47  30
  S 427 217
barplot(prop.table(table(train1$Survived,train1$Embark),2))


# ------------------------------------------------
#  App Title: 3D Model Viewer
#     Author: Irvin Alcaraz
# ------------------------------------------------
options(rgl.useNULL=TRUE)
if (!require("devtools")){
  install.packages("devtools")
  library("devtools")
  }
if (!require("shiny")){
  install.packages("shiny")
  library("shiny")
  }
if (!require("rgl")){
  install.packages("rgl")
  library("rgl")
  }
if (!require("shinyRGL")){
  install.packages("shinyRGL")
  library("shinyRGL")
  }
if (!require("reshape2")){
  install.packages("reshape2")
  library("reshape2")
  }
if (!require("RColorBrewer")){
  install.packages("RColorBrewer")
  library("RColorBrewer")
  }

if (!require("rglwidget")){
  install.packages("rglwidget")
  library("rglwidget")
}

shinyUI(navbarPage("Multiple Regression Visualization",
  tabPanel("3D Visualizer",

  tags$head(tags$link(rel = "icon", type = "image/x-icon",
                      href = "https://webresource.its.calpoly.edu/cpwebtemplate/5.0.1/common/images_html/favicon.ico")),

  p("When creating a model, it can be very helpful to visualize both the data and the model.
    Often we wish to create a prediction model for a response variable on more than one predictors.
    In the case of a single response and two predictors, we must use a third dimension to visualize the
    the data and model."),
  p("In this app, you will be able to  visualize the data and explore the effectiveness of different models
    for a numerical response variable. "),

  sidebarLayout(

    sidebarPanel(

      tags$title("3D Visualizer"),

      selectInput("dataset",label = "Select a dataset", choices = c("Iris"= "iris",
                                                                    "Cars" = "mtcars",
                                                                    "U.S." = "state.x77"
                                                                    ##,"Custom" = "upload"
                                                                    )),

      ##To do the 2D this you need to uncomment the end and add the third option
      conditionalPanel(condition = "input.dataset == 'iris'",
                       radioButtons("expTypes1", label = "Available Models: Sepal Area = ",
                                    choices = list("Sepal Length + Sepal Width" = 1,
                                                   "Sepal Length * sepal Width" = 2,
                                                   "Sepal Length + Sepal Width + Species" = 4,
                                                   "Sepal Length * Species + Sepal Width * Species" = 6,
                                                   "None" = 5),

                                    selected = 5)),
      conditionalPanel(condition = "input.dataset == 'mtcars'",
                       radioButtons("expTypes2", label = "Available Models: MPG =",
                                    choices = list("Horsepower + Weight" = 1,
                                                   "Horsepower * Weight" = 2,
                                                   "Horsepower + Weight + Transmission" = 4,
                                                   "Horsepower * Transmission + Weight * Transmission" = 6,
                                                   "None" = 5),
                                    selected = 5)),
      conditionalPanel(condition = "input.dataset == 'state.x77'",
                       radioButtons("expTypes3", label = "Available Models: Life Expectancy =",
                                    choices = list("Murder Rate + HS Graduation Rate" = 1,
                                                   "Murder * HSGrad" = 2,
                                                   "Murder + HSGrad + Region" = 4,
                                                   "Murder * Region + HSGrad * Region" = 6,
                                                   "None" = 5),
                                    selected = 5)),

      ####For file upload
#       conditionalPanel(condition = "input.dataset === 'upload'",
#                        fileInput("file", "Browse for a file",
#                                  accept=c("text/csv", "text/comma-separated-values,text/plain", ".csv")),
#                        strong("Please use numerical data formated as N,N,N"),
# #                        radioButtons("colTypes","C = Categorical, N = Numerical",
# #                                     c("N,N,N"=1,"N,N,N,C"=2,"N,N,C,N"=3,"N,C,N,N"=4),1),
#                        strong("Customize file format:"),
#                        checkboxInput("header", "Header", TRUE),
#                        radioButtons("sep", "Separator:",
#                                     c(Comma=",",Semicolon=";",Tab="\t"), ","),
#                        radioButtons("quote", "Quote",
#                                     c(None="","Double Quote"='"',"Single Quote"="'"), ""),
#                        strong("Check box to include interaction"),
#                        checkboxInput("interaction","", FALSE)
#                        ),

      div("Shiny app by",
          a(href="https://www.linkedin.com/in/irvinalcaraz",target="_blank",
            "Irvin Alcaraz"),align="right", style = "font-size: 8pt"),

      div("Base R code by",
          a(href="https://www.linkedin.com/in/irvinalcaraz",target="_blank",
            "Irvin Alcaraz"),align="right", style = "font-size: 8pt"),

      div("Shiny source files:",
          a(href="https://gist.github.com/calpolystat/bd0400c7ce3aacfa4973",
            target="_blank","GitHub Gist"),align="right", style = "font-size: 8pt"),

      div(a(href="http://www.statistics.calpoly.edu/shiny",target="_blank",
            "Cal Poly Statistics Dept Shiny Series"),align="right", style = "font-size: 8pt")

    ),
    mainPanel(

      tabsetPanel(
#         conditionalPanel(condition = "(!is.na(input.expTypes1) && input.expTypes1 != 3) || input.expTypes2 != 3 || input.expTypes3 != 3",
                         tabPanel("Plot",rglwidgetOutput("troisPlot",width="600px",height="600px")),
#                          ),
#         conditionalPanel(condition = "(!is.na(input.expTypes1) && input.expTypes1 == 3) || input.expTypes2 == 3 || input.expTypes3 == 3",
#                          tabPanel("Plot (2)",plotOutput("cat2d"))),
        tabPanel("Model Info",
                 withMathJax(),
                 helpText("The Response variable is:"),
                 verbatimTextOutput("responseVar"),
                 br(),
                 helpText("The current model is:"),
                 verbatimTextOutput("modelEQ"),
                 br(),
                 helpText("The corresponding \\(R^2-adjusted\\) is:"),
                 verbatimTextOutput("modelRsq")
        )
#         ,
#         tabPanel("Model Info (2)",
#                  withMathJax(),
#                  helpText("The Response variable is:"),
#                  verbatimTextOutput("catResp"),
#                  br(),
#                  helpText("The current model is:"),
#                  verbatimTextOutput("catModel"),
#                  br(),
#                  helpText("The corresponding \\(R^2-adjusted\\) is:"),
#                  verbatimTextOutput("catRsq")
#         )

        )

#       conditionalPanel(condition = "input.expTypes1 != 3 && !is.na(input.expTypes1)  || input.expTypes2 != 3 || input.expTypes3 != 3",
#                        tabsetPanel(
#                          tabPanel("Plot",webGLOutput("troisPlot",width="600px",height="600px")),
#                          tabPanel("Model Info",
#                                   withMathJax(),
#                                   helpText("The Response variable is:"),
#                                   verbatimTextOutput("responseVar"),
#                                   br(),
#                                   helpText("The current model is:"),
#                                   verbatimTextOutput("modelEQ"),
#                                   br(),
#                                   helpText("The corresponding \\(R^2-adjusted\\) is:"),
#                                   verbatimTextOutput("modelRsq")
#                          )
#
#                        )
#       ),
#       conditionalPanel(condition = "input.expTypes1 == 3 || input.expTypes2 == 3 || input.expTypes3 == 3",
#                        tabsetPanel(
#                          tabPanel("Plot",plotOutput("cat2d")),
#                          tabPanel("Model Info",
#                                   withMathJax(),
#                                   helpText("The Response variable is:"),
#                                   verbatimTextOutput("catResp"),
#                                   br(),
#                                   helpText("The current model is:"),
#                                   verbatimTextOutput("catModel"),
#                                   br(),
#                                   helpText("The corresponding \\(R^2-adjusted\\) is:"),
#                                   verbatimTextOutput("catRsq")
#                          )
#                        )
#
#       )

    )

  )
),
tabPanel("2D Help",
         p("When visualizing a categorical explanatory variable, we can utilize 2D plots instead. This is useful
           because it enables us to understand why the regression surfaces are seperate and gives us an expectation
           for what the regression surfaces will look like. Furthermore, 2D plot are by far, much easier to interpret."),
         sidebarLayout(
           sidebarPanel(selectInput("dataset1",label = "Select a dataset", choices = c("Iris"= "iris",
                                                                       "Cars" = "mtcars",
                                                                       "U.S." = "state.x77")),
#                         radioButtons("interact2D",label = "",
#                                      choices = c("No Interaction" = "no", "Interaction" = "yes")),
                        radioButtons("interact2D",label = "",
                                     choices = c("Simple Regression" = "simple",
                                                 "Categorical Predictor" = "no",
                                                 "Interaction" = "yes")),
                        div("Shiny app by",
                            a(href="https://www.linkedin.com/in/irvinalcaraz",target="_blank",
                              "Irvin Alcaraz"),align="right", style = "font-size: 8pt"),

                        div("Base R code by",
                            a(href="https://www.linkedin.com/in/irvinalcaraz",target="_blank",
                              "Irvin Alcaraz"),align="right", style = "font-size: 8pt"),

                        div("Shiny source files:",
                            a(href="https://gist.github.com/calpolystat/bd0400c7ce3aacfa4973",
                              target="_blank","GitHub Gist"),align="right", style = "font-size: 8pt"),

                        div(a(href="http://www.statistics.calpoly.edu/shiny",target="_blank",
                              "Cal Poly Statistics Dept Shiny Series"),align="right", style = "font-size: 8pt")

           ),
           mainPanel(
                    tabsetPanel(
                                tabPanel("Plot",plotOutput("cat2d")),
                                tabPanel("Model Info",
                                         withMathJax(),
                                         helpText("The Response variable is:"),
                                         verbatimTextOutput("catResp"),
                                         br(),
                                         helpText("The current model is:"),
                                         verbatimTextOutput("catModel"),
                                         br(),
                                         helpText("The corresponding \\(R^2-adjusted\\) is:"),
                                         verbatimTextOutput("catRsq"))
                    )
             )
         )
        )
  ))


# Function 'netReturns'
# Killian Martin--Horgassan
# 17-03-2015

# Extracts the net returns for a vector of stock prices

netReturns <- function(x) {
	LENGTH <- length(x)
	RESULT <- rep(0,LENGTH-1)
	for (i in 1:LENGTH-1) {
		RESULT[i] <- (x[i+1]-x[i])/x[i]
		}
	output <- RESULT
}


# Setup
# -----
#
# The CDSW library includes
# a number of helper functions you can use from within R sessions.

library('cdsw')

# [ggplot2](http://ggplot2.org/) is a great way to make pretty graphs.

library('ggplot2')

# Load Data
# ---------
#
# Download and load Cars93 car data.

system('wget -nc https://raw.github.com/vincentarelbundock/Rdatasets/master/csv/MASS/Cars93.csv')
cars <- read.csv('Cars93.csv')
head(cars)
summary(cars$Type)

# Explore
# -------

qplot(cars$MPG.city, main="Cars MPG City")
qplot(cars$MPG.city, cars$Horsepower,
  main="City MPG vs. Horsepower",
  xlab="City MPG", ylab="Horsepower")
qplot(cars$Wheelbase, cars$Weight,
    main="Wheelbase Vs. Car Weight",
    xlab="Wheelbase", ylab="Car Weight") +
  geom_smooth(method = "loess")

# Model
# -----
#
# Regress City MPG on number of cylinders and weight

fit <- lm(MPG.city ~ Cylinders + Weight, data=cars)
summary(fit)

# Worker Engines
# -----------------
#
# Worker engines run on remote containers and can be networked together
# to run distributed jobs.  Using workers, you can easily scale your analysis
# 100s of cores.  All workers share the same project filesystem, have
# access to a virtual private network, and multiplex their output into
# a single master engine for easy debugging.
#
# The following command launches two workers and runs some code remotely:

# workers <- launch.workers(n=2, cpu=0.2, memory=0.5, code="print('Hello from a CDSW Worker')")

# You can stop workers with `stop.workers()`.  All workers will automatically
# be cleaned up when you stop the session as well (top-right session drop down).


#==============================================================================
#	Test for gbm.
#==============================================================================

source("tests.r")

test.data <- list(
	call = list(
		substitute(
			gbm(Sepal.Length ~ ., data = iris, distribution = "gaussian")
		),
		substitute(
			gbm(Species ~ ., data = iris, distribution = "multinomial")
		)
	),
	formula = list(
		Sepal.Length ~ Sepal.Width + Petal.Length + Petal.Width + Species,
		Species ~ Sepal.Length + Sepal.Width + Petal.Length + Petal.Width
	),
	model.type = list("regression", "classification")
)

test.model.adapter("gbm", iris, test.data, predict.args = list(n.trees = 10))

rm(test.data)


# tu je več grafov, kot jih je na koncu vključeno v poročilo,
# a sem želel prikazati tudi fazo "eksploratorne analize"

# ZEMLJEVID - delež ####
delezi <- stock %>%
  filter(age == "total", year == "2019") %>%
  select(-"year", -"age") %>%
  group_by(country) %>%
  summarise(number = sum(number, na.rm = TRUE)) %>%
  inner_join(drzave[c("country", "leto", "populacija")] %>%
               filter(leto == "2018")) %>%
  mutate(delez = number / populacija) %>%
  select(-"leto", -"number", -"populacija")

zemljevidStock <- tm_shape(merge(svet, delezi,
                                 by.x = "NAME", by.y = "country")) +
  tm_polygons("delez", midpoint = 0.4, title = "Delež") +
  tm_layout(main.title = "Delež priseljencev glede na populacijo države") +
  tm_legend(position = c("left", "center"))

# GRAF - starostne skupine ####
starostneSkupine <- stock %>%
  filter(age != "total") %>%
  group_by(year, age, gender) %>%
  summarise(number = sum(number, na.rm = TRUE))
grafStarostleta <- ggplot(starostneSkupine, aes(x = year, y = number)) + #eh
  geom_line() + facet_grid(age~gender)

grafStarostskupine <- ggplot(starostneSkupine, aes(x = age, y = number)) +
  geom_point() + facet_grid(year~gender)

grafStarostskatla <- ggplot(starostneSkupine %>%
                        group_by(year, age) %>%
                        summarise(number = sum(number, na.rm = TRUE)),
                      aes(x = age, y = number / 1000)) +
  geom_boxplot() +
  geom_line(data = starostneSkupine %>% group_by(age, year) %>%
                               summarise(povp = sum(number, na.rm = TRUE)) %>%
               group_by(age) %>% summarise(med = median(povp)),
                             aes(x = age, y = med / 1000, group = 1, color = "red"),
            show.legend = FALSE) +
  xlab("Starost (leta)") + ylab("Število migrantov (v tisočih)") +
  ggtitle("Število migrantov glede na starost v obdobju 1990-2019")

# GRAF - države (to je v shiny) ####
emigracija <- migranti %>% group_by(origin, Year) %>%
  summarise(number = sum(number, na.rm = TRUE))
imigracija <- migranti %>% group_by(destination, Year) %>%
  summarise(number = sum(number, na.rm = TRUE))

drzave$leto[drzave$leto == 2018] <- 2019 #manjša guljufija
master <- drzave %>%
  inner_join(emigracija, by = c("country" = "origin", "leto" = "Year")) %>%
  rename(emigracija = number) %>%
  inner_join(imigracija, by = c("country" = "destination", "leto" = "Year")) %>%
  rename(imigracija = number)

grafBdp <- ggplot(master, aes(x = BDP, y = imigracija)) + geom_point() +
  scale_x_log10() + scale_y_log10()
#  facet_grid(rows = "leto") + geom_smooth(method = "lm")

grafBdppc <- ggplot(master, aes(x = BDPpc, y = emigracija)) + geom_point() +
  scale_y_log10() + scale_x_log10()

# trash
grafIzobrazba <- ggplot(master, aes(x = izobrazenost, y = imigracija)) + geom_point() +
  scale_y_log10()
grafHDI <- ggplot(master, aes(x = HDI, y = imigracija)) + geom_point() +
  scale_y_log10()

# RELIGIJE (2019) ####
religigranti <- religije %>% inner_join(emigracija %>%
                                          filter(Year == "2019"),
                                        by = c("country" = "origin")) %>%
  select(-"Year", emigracija = number) %>% inner_join(imigracija %>% filter(Year == "2019"),
                                 by = c("country" = "destination")) %>%
  select(-"Year", imigracija = number) %>%
  inner_join(drzave %>% filter(leto == "2019") %>%
               select(-"leto", -"BDP", -"izobrazenost", -"HDI", -"BDPpc"),
             by = c("country")) %>%
  arrange(country, desc(procent))

dominantna <- distinct(religigranti, country, .keep_all = TRUE) %>%
  mutate(emigracija = emigracija / populacija, imigracija = imigracija / populacija)

grafDominantna <- ggplot(dominantna %>% select(-"procent", -"populacija") %>%
                 gather(preseljevanje, delez, 3:4), aes(x = delez, fill = preseljevanje)) +
  geom_histogram() + facet_grid(Religija~.)

država <- dominantna$country

grafDrzavarelig <- ggplot(dominantna %>% arrange(Religija, desc(emigracija)) %>%
                      mutate(country = 1:174), aes(x = country, y = - emigracija, fill = Religija, država = država)) +
  geom_col() + geom_col(data = dominantna %>% arrange(Religija, desc(imigracija)) %>%
                          mutate(country = 1:174), aes(x = country, y = imigracija, fill = Religija)) +
  geom_hline(yintercept = 0) + ylab("Delež emigracije / Delež imigracije") + xlab("Država") +
  ggtitle("Delež imigrantov/emigrantov glede na religijo (2019)") + theme(axis.text.x = element_blank(),
                                                                   axis.ticks.x = element_blank())

grafDrzavarelig <- ggplotly(grafDrzavarelig, tooltip = "država", width = 1000, height = 600)

# SLOVENIJA ####
slovenijaEmi <- migranti %>% filter(origin == "Slovenia") %>%
  select(-"origin")
slovenijaImi <- migranti %>% filter(destination == "Slovenia") %>%
  select(-"destination")
slovenijaStock <- stock %>% filter(country == "Slovenia") %>%
  select(-"country")
slovenijaPodatki <- master %>% filter(country == "Slovenia") %>%
  select(-"country")

popularImi <- slovenijaImi %>% filter(origin != "Total") %>%
  group_by(origin) %>%
  summarise(number = sum(number, na.rm = TRUE)) %>%
  arrange(desc(number))
popularImi <- popularImi[1:15,]
poreklo <- popularImi$origin

popularEmi <- slovenijaEmi %>% filter(destination != "Total") %>%
  group_by(destination) %>%
  summarise(number = sum(number, na.rm = TRUE)) %>%
  arrange(desc(number))
popularEmi <- popularEmi[1:15,]
cilj <- popularEmi$destination

grafSloimig <- ggplot(popularImi %>% mutate(origin = 1:15),
                     aes(x = origin, y = number / 1000, poreklo = poreklo)) +
  geom_col() + xlab("Poreklo") + ylab("Število (v tisočih)") +
  theme(axis.text.x = element_blank(), axis.ticks.x = element_blank())
grafSloimig <- ggplotly(grafSloimig, tooltip = "poreklo", width = 850)

grafSloemig <- ggplot(popularEmi %>% mutate(destination = 1:15),
                      aes(x = destination, y = number / 1000, cilj = cilj)) +
  geom_col() + xlab("Cilj") + ylab("Število (v tisočih)") +
  ggtitle("Kdo v Slovenijo pride in kam Slovenec gre") +
  theme(axis.text.x = element_blank(), axis.ticks.x = element_blank())
grafSloemig <- ggplotly(grafSloemig, tooltip = "cilj", width = 850)

grafSlomig <- subplot(grafSloimig, grafSloemig, titleX = TRUE, titleY = TRUE, margin = 0.08, shareY = TRUE)

grafSlostock <- ggplot(slovenijaStock %>% filter(age != "total") %>%
                         rename(Starost = age),
                       aes(x = year, y = number)) +
  geom_col(position = "dodge", aes(fill = Starost)) +
  geom_line(data = slovenijaStock %>% filter(age != "total") %>%
              group_by(year, gender) %>% summarise(number = mean(number)),
            aes(x = year, y = number)) +
  facet_grid(~gender) + xlab("Leto") + ylab("Število") +
  ggtitle("Število imigrantov glede na spol in starost v obdobju 1990-2019")


##' @param min_or_max string, either 'max' or 'min'
##' @param taskRHSconstraint constraint object as in hitandrun where task is on the RHS. No lamdbas.
##' @param num_muscles integer
lpsolve_muscles_for_task <- function(min_or_max, taskRHSconstraint, num_muscles) {
    c_in_cTx <- rep(1, ncol(taskRHSconstraint$constr))
    lp_result <- lp(min_or_max, objective.in = c_in_cTx, const.mat = taskRHSconstraint$constr,
        const.dir = taskRHSconstraint$dir, const.rhs = taskRHSconstraint$rhs, compute.sens = 0)
    return(lp_result)
}


#=============================================================
# c:/1work/Python/djcode/fn_portal/utils/calc_smallfish_flentlen.r
# Created: 16 Sep 2016 09:51:18
#
# DESCRIPTION:
#
#
# A little helper script to calculate flen-Tlen coefficients for
# species found in the small fish database.  Allows us to estimate
# flen when we didn't bother to collect it.
#
# A. Cottrill
#=============================================================

# LIBRARIES:
library(RODBC)
library(reshape2)
library(plyr)

#=============================================================

DBASE <- 'C:/1work/Python/djcode/fn_portal/utils/mdbs/Smallfish.mdb'

DBConnection <- odbcConnectAccess(DBASE, uid = "")
data <- sqlFetch(DBConnection, 'get_both_flen_tlen', colnames=FALSE,
               rownames=FALSE, stringsAsFactors=FALSE)
names(data) <- toupper(names(data))
head(data)
str(data)
nrow(data)
odbcClose(DBConnection)

#subset our data to include only those species with some minumumn
#number of observations:
minNobs <- 5
nobsSpc <- count(data, 'SPC')
nobsSpc <- nobsSpc[nobsSpc[,2]>minNobs,]
data <-  data[data$SPC %in% nobsSpc$SPC,]

flen_tlen<- function(x){
  # a helper function used by plyr to fit a linear regession of the data
  # data in x (x is a dataframe that must contain the variables flen
  # and tlen.

  fit <- try( lm(TLEN ~ FLEN, data=x), silent=TRUE)
  if(inherits(fit, 'try-error')){
    return(data.frame(slope=NA, intercept=NA, N=NA))
  } else {
    coefs = coef(fit)
    return(data.frame(slope=coefs[2], intercept=coefs[1], N=nrow(x)))
  }

  }

flen_tlen_coefs <-  ddply(data, 'SPC', flen_tlen)

#convert the species codes back to text and add the leading 0's
flen_tlen_coefs$SPC <- sprintf('%03d', flen_tlen_coefs$SPC)

DBConnection <- odbcConnectAccess(DBASE, uid = "", pwd = "")
sqlSave(DBConnection, flen_tlen_coefs, safer = FALSE, fast = TRUE,
        rownames=FALSE)
odbcClose(DBConnection)


####
# calculates the "central parent" (CP) value,
# a.k.a. the "household" language environment,
# a.k.a. an average of the M, B or C language abilities of
# all (up to 4) Elders in each Subject's childhood household
####

rm(list=ls())
library(dplyr)

# read in data
source('inread.r')
almost_everything <- inread('data/2015_lmsim_data.csv')
# the 4 elders in a household are labeled A, B, C and D

# clean the data:
# remove elders less than ten years older than subject
# remove elders with missing birthyears
gap <- 10

a <- almost_everything %>%
  select(Subject_Code, Birthyear,
    a.Birthyear, a.mong.spok, a.chin.spok)
a$a.Birthyear <- as.numeric(a$a.Birthyear)
a <- a[a$Birthyear-a$a.Birthyear>gap & a$a.Birthyear>1800 ,]

b <- almost_everything %>%
  select(Subject_Code, Birthyear,
    b.Birthyear, b.mong.spok, b.chin.spok)
b$b.Birthyear <- as.numeric(b$b.Birthyear)
b <- b[b$Birthyear-b$b.Birthyear>gap & b$b.Birthyear>1800,]

c <- almost_everything %>%
  select(Subject_Code, Birthyear,
    c.Birthyear, c.mong.spok, c.chin.spok)
c$c.Birthyear <- as.numeric(c$c.Birthyear)
c <- c[c$Birthyear-c$c.Birthyear>gap & c$c.Birthyear>1800,]

d <- almost_everything %>%
  select(Subject_Code, Birthyear,
    d.Birthyear, d.mong.spok, d.chin.spok)
d$d.Birthyear <- as.numeric(d$d.Birthyear)
d <- d[d$Birthyear-d$d.Birthyear>gap & d$d.Birthyear>1800,]

# almost_everything: 629 rows
# a: 615
# b: 615
# c: 576
# d: 610

# recombine the cleaned data and
# extract relevant columns
x <- almost_everything %>%
  select(Subject_Code) %>%
  left_join(a) %>%
  left_join(b) %>%
  left_join(c) %>%
  left_join(d) %>%
  select(
  Subject_Code,
  a.mong.spok, a.chin.spok,
  b.mong.spok, b.chin.spok,
  c.mong.spok, c.chin.spok,
  d.mong.spok, d.chin.spok)

#---- MBCnum ----
# set up special version of MBC function
# maps M, B, C to 0, 0.5, 1 (skipping MBC stage)
  # input (1, 2, 3, 4, 5) = (FLUENT, MEDIUM, LITTLE, NONE, UNKNOWN)
  # output (1, 0.5, 0) corresponds to (M, B, C) in other analyses

MBCnum <- function(m, c){
        mbc <- ifelse(m < 3 & c < 3, 0.5,
                ifelse(m < 3, 1,
                ifelse(c < 3, 0, NA)))
        return(mbc)
        }
#---- end label ----

#---- MBCalpha ----
# normal version of MBC function
# summarizes mong.spok and chin.spok to one value
# input (1, 2, 3, 4, 5) = (FLUENT, MEDIUM, LITTLE, NONE, UNKNOWN)
# output (M, B, C)

MBCalpha <- function(m, c){
  mbc <- ifelse(m < 3 & c < 3, "B",
                ifelse(m < 3, "M",
                       ifelse(c < 3, "C", NA)))
  return(mbc)
}
#---- end label ----

# get MBC values (numeric version) for each elder
x <- x %>%
  mutate(a.MBC1 = MBCnum(a.mong.spok, a.chin.spok)) %>%
  mutate(b.MBC1 = MBCnum(b.mong.spok, b.chin.spok)) %>%
  mutate(c.MBC1 = MBCnum(c.mong.spok, d.chin.spok)) %>%
  mutate(d.MBC1 = MBCnum(d.mong.spok, d.chin.spok))

# calculate mean of Elders for each Subject
avg.elder.num <- x %>%
    select(a.MBC1, b.MBC1, c.MBC1, d.MBC1) %>%
    rowMeans(na.rm=TRUE)

# convert mean back to MBC scale
    # if 0 <= x < .25 then C
    # if .25 <= x <= .75 then B
    # if .75 < x <= 1 then M
avg.elder.MBC <-
  ifelse(avg.elder.num >=0 & avg.elder.num < 0.25, "C",
    ifelse(avg.elder.num >= 0.25 & avg.elder.num <= 0.75, "B",
      ifelse(avg.elder.num > 0.75 & avg.elder.num <=1, "M", NA)))

# attach results to main df
x <- cbind(x, avg.elder.num, avg.elder.MBC)
rm(avg.elder.num, avg.elder.MBC)

# add MBC values (alpha version) for each elder
x <- x %>%
  mutate(a.MBC = MBCalpha(a.mong.spok, a.chin.spok)) %>%
  mutate(b.MBC = MBCalpha(b.mong.spok, b.chin.spok)) %>%
  mutate(c.MBC = MBCalpha(c.mong.spok, d.chin.spok)) %>%
  mutate(d.MBC = MBCalpha(d.mong.spok, d.chin.spok))

# make df with MBC values (alpha version) for each subject
y <- almost_everything %>%
  select(Subject_Code, mong.spok, chin.spok) %>%
  mutate(self.MBC = MBCalpha(mong.spok, chin.spok))
# make df with elder-to-subject relationships
z <- almost_everything %>%
  select(Subject_Code,
    a.Relationship, b.Relationship, c.Relationship, d.Relationship)

# combine all three dfs
yxz <-
  left_join(y, x, by = "Subject_Code") %>%
  left_join(z, by = "Subject_Code")
rm(x, y, z)

# drop raw language data
mbc.df <- select(yxz,
  Subject_Code,
  self.MBC, avg.elder.MBC, avg.elder.num,
  a.Relationship, a.MBC,
  b.Relationship, b.MBC,
  c.Relationship, c.MBC,
  d.Relationship, d.MBC)

# save to txt
csvutf8 <- function(yi, filename) {
  write.table(yi, file = filename,
    sep = ",", row.names = FALSE, fileEncoding = "UTF-8")
}

csvutf8(mbc.df, "data/mbc_kid_cp.csv")


# Correlation analysis
#
# sessionInfo()
# R version 4.0.2 (2020-06-22)
# Platform: x86_64-apple-darwin17.0 (64-bit)
# Running under: macOS Catalina 10.15.6

# Matrix products: default
# BLAS:   /System/Library/Frameworks/Accelerate.framework/Versions/A/Frameworks/vecLib.framework/Versions/A/libBLAS.dylib
# LAPACK: /Library/Frameworks/R.framework/Versions/4.0/Resources/lib/libRlapack.dylib

# locale:
# [1] en_US.UTF-8/en_US.UTF-8/en_US.UTF-8/C/en_US.UTF-8/en_US.UTF-8

# attached base packages:
# [1] stats     graphics  grDevices utils     datasets  methods
# [7] base

# other attached packages:
#  [1] piano_2.4.0       ggpubr_0.3.0      viridis_0.5.1
#  [4] viridisLite_0.3.0 forcats_0.5.0     stringr_1.4.0
#  [7] purrr_0.3.4       readr_1.3.1       tidyr_1.1.0
# [10] tibble_3.0.1      ggplot2_3.3.0     tidyverse_1.3.0
# [13] reshape_0.8.8     dplyr_0.8.5       biomaRt_2.44.0
#
# Rasool Saghaleyni   2020-08-25
####################################################################

# *** CHANGE THIS PATH TO REPOSITORY PATH IN YOUR LOCAL COMPUTER ***

library(biomaRt)
library(dplyr)
library(reshape)
library(tidyverse)
library(viridis)
library(ggpubr)
library(piano)

mart <- useMart("ENSEMBL_MART_ENSEMBL", dataset = "hsapiens_gene_ensembl", host="www.ensembl.org")
ensembl2name <- getBM(attributes=c("ensembl_gene_id","external_gene_name"),mart=mart)

# import samples table
  sam <- read.delim(paste(getwd(),'/data/samples_for_correlation_analysis.txt',sep=''))
  rownames(sam) <- sam[,1]
  sam <- sam[,2:17]
  samples_epo <- sam[,grep('EPO',colnames(sam))]
  samples_epo['epoQP',] <- samples_epo['productivity',]
  samples_gfp <- sam[,grep('GFP',colnames(sam))]
  samples_gfp['gfpQP',] <- samples_gfp['productivity',]

# import TPMs
tpm <- read.delim(paste(getwd(),'/data/35samples_TPM.txt',sep=''))
rownames(tpm) <- tpm[,1]
tpm <- tpm[,-1]
colnames(tpm) = rep(colnames(sam), times = c(2,2,2,2,2,3,2,2,2,2,4,2,2,2,2,2))

# preparation for correlation analysis
  y_epo <- tpm[,colnames(samples_epo)]
  y_gfp <- tpm[,colnames(samples_gfp)]

method = "spearman"
# correlation analysis
  corel <- matrix(nrow=nrow(y_gfp), ncol=4)
  for(i in 1:nrow(y_gfp)) {
    corel[i,1] <- cor.test(as.numeric(samples_epo['epoQP',]),as.numeric(y_epo[i,]), method=method)[["estimate"]]
    corel[i,2] <- cor.test(as.numeric(samples_epo['epoQP',]),as.numeric(y_epo[i,]), method=method)[["p.value"]]
    corel[i,3] <- cor.test(as.numeric(samples_gfp['gfpQP',]),as.numeric(y_gfp[i,]), method=method)[["estimate"]]
    corel[i,4] <- cor.test(as.numeric(samples_gfp['gfpQP',]),as.numeric(y_gfp[i,]), method=method)[["p.value"]]
  }
  corel <- as.data.frame(corel)
  colnames(corel) <- c("epo_coef",'epo_pval','gfp_coef',"gfp_pval")
  rownames(corel) <- rownames(y_gfp)

# finding significantly correlating genes
  df <- corel
  rownames(df) <- rownames(corel)
  th = 0.5
  ## filtering non significant genes based on pvalue lower than 0.05
    df$epo_coef[which(df$epo_pval > 0.05)] = 0
    df$gfp_coef[which(df$gfp_pval > 0.05)] = 0
  ## filtering genes with mean of tpm lower than 10
    df$epo_coef[which(rowMeans(tpm[,3:8]) < 10)] <- 0
    df$gfp_coef[which(rowMeans(tpm[,9:16]) < 10)] <- 0
  ## taging high correlating genes
    df$sig <- 'non'
    df$sig[which(df$epo_coef > th)] <- 'epo+'
    df$sig[which(df$epo_coef < -th)] <- 'epo-'
    df$sig[which(df$gfp_coef > th)] <- 'gfp+'
    df$sig[which(df$gfp_coef < -th)] <- 'gfp-'
    df$sig[which(df$epo_coef > th & df$gfp_coef > th)] <- 'epo+gfp+'
    df$sig[which(df$epo_coef < -th & df$gfp_coef < -th)] <- 'epo-gfp-'
    df$sig[which(df$epo_coef > th & df$gfp_coef < -th)] <- 'epo+gfp-'
    df$sig[which(df$epo_coef < -th & df$gfp_coef > th)] <- 'epo-gfp+'
    df$prot <- 'non'
    df$prot[which(df$epo_coef > th)] <- 'epo'
    df$prot[which(df$epo_coef < -th)] <- 'epo'
    df$prot[which(df$gfp_coef > th)] <- 'gfp'
    df$prot[which(df$gfp_coef < -th)] <- 'gfp'
    df$prot[which(df$epo_coef > th & df$gfp_coef > th)] <- 'both'
    df$prot[which(df$epo_coef < -th & df$gfp_coef < -th)] <- 'both'
    df$prot[which(df$epo_coef > th & df$gfp_coef < -th)] <- 'both'
    df$prot[which(df$epo_coef < -th & df$gfp_coef > th)] <- 'both'
  ## filtering non correlating genes
    sig <- df[-which(df$prot == 'non'),]
    sig <- merge(x=sig, y=ensembl2name, by.x=0, by.y=1, all.x=TRUE)
    rownames(sig) <- sig$Row.names
    sig <- distinct(sig)
    sig <- sig[!is.na(sig$external_gene_name),]
    sig <- sig[!duplicated(sig$external_gene_name),]

# saving table
write.table(sig, paste(getwd(),'/results/',"35samples_corel_spearman_epo_thr_",th,".txt",sep=""), quote = FALSE, row.names = FALSE, col.names = FALSE, sep='\t')