SummaryHistograms <- function(dt, summ) {
  # This function creates the data that will be plot as histograms

  data <- dt[, .(logAvgGDPpc, gender, preference, country)]
  data[summ, genderIndex := i.GenderIndex, on = "country"]

  # Summary for the GDP
  data[logAvgGDPpc <= quantile(logAvgGDPpc, 0.25, na.rm = TRUE),
       GDPquant := 1]
  data[is.na(GDPquant) & logAvgGDPpc <= quantile(logAvgGDPpc, 0.50, na.rm = TRUE),
       GDPquant := 2]
  data[is.na(GDPquant) & logAvgGDPpc <= quantile(logAvgGDPpc, 0.75, na.rm = TRUE),
       GDPquant := 3]
  data[is.na(GDPquant),
       GDPquant := 4]
  # Summary for the Gender equality index
  data[genderIndex <= quantile(genderIndex, 0.25, na.rm = TRUE),
       GEIquant := 1]
  data[is.na(GEIquant) & genderIndex <= quantile(genderIndex, 0.50, na.rm = TRUE),
       GEIquant := 2]
  data[is.na(GEIquant) & genderIndex <= quantile(genderIndex, 0.75, na.rm = TRUE),
       GEIquant := 3]
  data[is.na(GEIquant),
       GEIquant := 4]

  # Assign mean of the bin for GDP and GEI
  for (i in 1:length(data$GEIquant)) {
    data[GDPquant == i, meanGenderGDP := mean(gender, na.rm = T), by = "preference"]
    data[GEIquant == i, meanGenderGEI := mean(gender, na.rm = T), by = "preference"]
  }

  data <- unique(data[, c(-1, -2, -4, -5)])

  data[preference == "negrecip", meanGenderGDP := -1 * meanGenderGDP]
  data[preference == "risktaking", meanGenderGDP := -1 * meanGenderGDP]
  data[preference == "patience", meanGenderGDP := -1 * meanGenderGDP]

  data[preference == "negrecip", meanGenderGEI := -1 * meanGenderGEI]
  data[preference == "risktaking", meanGenderGEI := -1 * meanGenderGEI]
  data[preference == "patience", meanGenderGEI := -1 * meanGenderGEI]

  return(data)
}


# Clase 15: Evaluacion practica en clases #4.
#################################################################
cat("\014")
rm(list=ls())
graphics.off()

# Cargar Pacman
if (!require("pacman")) install.packages("pacman"); library(pacman)

# Cargar paquete para cargar bases que no son de R.
p_load(foreign) # significa "foraneo"
dat <- read.dta("cow.dta") # cargar base en  R (hasta el momento solo la habiamos descargado).

head(dat)

summary(dat)

# country Country Name
# ccode: country code
# pop: Population in thousands
# rgdpch: Real GDP/capita
# democracy: measure of democracy
# vdiss: Violent dissent based on terrorist events and fatalities.
# repression: Violations of physical integrity rights.

#################################################################
# Motivacion
#################################################################

# En esta clase pensaras en la siguiente pregunta:
# Que hace a los paises ricos? Sera la democracia? Y/o la estabilidad?  Y/o La cantidad de poblacion?

#################################################################
# (1) VD?
#################################################################

# Cual es la variable dependiente?
# Responde:

#################################################################
# Crea una hipotesis y una hipotesis alternativa
#################################################################

# En esta seccion deberas pensar en hipotesis bivariadas.

# (a) Hipotesis: Yo creo que X1 causa Y porque....?

# (b) Hipotesis alternativa: Yo creo que X2 causa Y porque...?

#################################################################
# Estima dos modelos lineales
#################################################################

# (1) Estima dos modelos lineales, uno por cada hipotesis.
# (2) En cada uno, incluye variables independientes (o "controles") de tu preferencia.

# Modelo 1

# Modelo 2

#################################################################
# Construye una tabla
#################################################################

# Construye una tabla que contenga ambos modelos

p_load(texreg) # paquete para hacer tablas con varios modelos.

# Tabla abajo

#################################################################
# Construye un grafico
#################################################################

# Construye un grafico que contenga ambos modelos

p_load(coefplot) # paquete para hacer tablas con varios modelos.

# Grafico abajo

#################################################################
# Respuesta
#################################################################

# Que hace a los paises ricos?
# Responde:

# Despues de estimar ambos modelos, el que "gana" es el modelo [1 o 2?] porque
# el coeficiente es [mayor o menor]?


# Dual Luciferase Analysis Pipeline
# Elias Brandorff, SILS Amsterdam Version 1
# import excel data from GloMax luminescence machine
# level 1 calculations: normalize expression to internal control
# plot normalized expression values
# produce a summary table
# level 2 calculations: normalize expression of experimental to control condition
# plot relative expression

#set working path
setwd("C:/DualReporterPipeline/")

#install tidyverse package wich contains 3 essential componetns: tydr, ggplot2 and readxl. readxl enables reading excel files.
install.packages("tidyverse")
# load the relevant libraries
library(readxl)
library(tidyr)
library(ggplot2)
library(dplyr)

# import excel output GloMax with readxl into a dataframe.The datasheet must be prepared by creating separate sheets for firefly and renilla.
# import both data into separate dataframes
#  either point to number or name of the correct sheet
firefly <- read_excel("DualReporter_example_data.xlsx", sheet = "firefly")
renilla <- read_excel("DualReporter_example_data.xlsx", sheet = "renilla")

#normalization to internal control
FR <- firefly / renilla

# convert dataframe to tidy format
FR_tidy <- gather(FR, condition, FR)

#plotting FR ratios for data overview
p1 <- ggplot(FR_tidy, aes(x = condition, y = FR)) +
  geom_jitter(position=position_jitter(0.1), cex=2, color="grey40") +
  stat_summary(fun.y = median, fun.ymin = median, fun.ymax = median,
               geom = "crossbar", width = 0.2)

p1
png("FR_summary.png", width = 300, height = 300)
plot(p1)
dev.off()

#FR summary
FR2_tidy2 <- FR_tidy %>%
  group_by(condition) %>%
  dplyr::summarise(mean = mean(FR, na.rm = TRUE))
FR_tidy2

# produce a summar table
install.packages("gridExtra")
library(gridExtra)

#produce a table in PDF for publication containing the mean FR ratio per condition
pdf("FR1.pdf", height=11, width=10)
grid.table(FR_tidy2)
dev.off()

#doing the relative calculation i.e. normalize to expression of the empty vector "Ev"
cond1 <- FR$B/FR$A
cond2 <- FR$C/FR$A
relative <- tibble(cond1, cond2)
relative_tidy <- gather(relative, condition, FC)
relative_tidy

p2 <- ggplot(relative_tidy, aes(condition, FC)) +
  geom_point() +
  stat_summary(fun.y = median, fun.ymin = median, fun.ymax = median,
               geom = "crossbar", width = 0.2) +
  ylab("FC luciferase expression / EV normalized to renilla") +
  ylim(0,1250)

p2

png("FC_lucexpression.png", width = 300, height = 300)
plot(p2)
dev.off()


x <- c(1,2,3,4,5)
mean <- mean(x)

print(mean)


library(data.table)
library(DCGen)

# getDefaultInputData <- function() {
#   data.table(
#     Expert = c("Expert A", "Expert B", "Expert C"),
#     M = rep("Triangle", 3),
#     M_1 = c(54.2, 158.8, 204.4),
#     M_2 = c(10, 30, 30),
#     M_3 = c(150, 230, 410),
#     N = rep("Triangle", 3),
#     N_1 = c(2.3, 5.7, 7.1),
#     N_2 = c(0, 2, 2),
#     N_3 = c(5, 15, 10),
#     "T" = rep("Normal", 3),
#     T_1 = c(5.1, 9.9, 3.5),
#     T_2 = c(1.5, 1.5, 1.1),
#     T_3 = c(NA, NA, NA)
#   )
# }

getDefaultInputData <- function() {
  data.table(
    Expert = c("Expert A", "Expert B", "Expert C"),
    M = rep("Gamma", 3),
    M_1 = round(c(3.03, 12.374, 2.8056), 2),
    M_2 = round(1/c(17.8452, 12.84931, 71.641), 2),
    M_3 = c(NA, NA, NA),
    N = rep("Gamma", 3),
    N_1 = round(c(4.18559, 5.085, 11.0953), 2),
    N_2 = round(1/c(0.53278, 1.095314, 0.59769), 2),
    N_3 = c(NA, NA, NA),
    "T" = rep("Gamma", 3),
    T_1 = round(c(22.21202, 38.27075, 14.34556), 2),
    T_2 = round(1/c(0.229155, 0.260251, 0.246069), 2),
    T_3 = c(NA, NA, NA)
  )
}

getNewInputData <- function(id) {
  data.frame(
    Expert = paste0("Expert", id),
    M = "Normal", M_1 = 100, M_2 = 1, M_3 = NA,
    N = "Normal", N_1 = 5, N_2 = 1, N_3 = NA,
    "T" = "Normal", T_1 = 4, T_2 = 1, T_3 = NA
  )
}

showInputData <- function(dat) {
  data.table(
    Expert=dat[["Expert"]],
    M=paste0(dat[[2]], "(", apply(dat[, 3:5], 1, function(x) {x <- x[!is.na(x)]; paste(x, collapse = ", ")}),")"),
    N1=paste0(dat[[6]], "(", apply(dat[, 7:9], 1, function(x) {x <- x[!is.na(x)]; paste(x, collapse = ", ")}),")"),
    "t'"=paste0(dat[[10]], "(", apply(dat[, 11:13], 1, function(x) {x <- x[!is.na(x)]; paste(x, collapse = ", ")}),")")
  )
}

inputELCs <- function(dat) {
  experts <- apply(dat, 1, function(x) new_expert(x[1], x[2], x[3:5], x[6], x[7:9], x[10], x[11:13]))
  experts <- aggregate_experts(experts)

  experts
}

distribution_setter <- function(dat, id, dist='Normal', pars=c(0.1, 0.1, NA)) {
  dist <- as.character(dat[,1])
  pars <- unlist(dat[, 2:4])

  def <- rbind(Gamma=c(1, 0.1, NA),
               Normal=c(1, 0.1, NA),
               LogNormal=c(0, 0.1, NA),
               StudentT=c(1, 0.1, 3),
               LogStudentT=c(0, 0.1, 3),
               Triangle=c(2, 1, 3))

  def[dist, ] <- pars

  fluidPage(

    selectInput(paste0(id, "_dist"), paste0("Distribution of ", id),
                c("Gamma", "Normal", "LogNormal", "StudentT", "LogStudentT", "Triangle"), selected = dist, width="50%"),

    conditionalPanel( condition = paste0("input.", id, "_dist == 'Gamma'"), fluidRow(
      column(1),
      column(5, numericInput(paste0(id, "_shape"), label = "Shape", value = def['Gamma', 1], min=0)),
      column(5, numericInput(paste0(id, "_rate"), label = "Rate", value = def['Gamma', 2], min=0)))),

    conditionalPanel( condition = paste0("input.", id, "_dist == 'Normal'"), fluidRow(
      column(1),
      column(5, numericInput(paste0(id, "_mean"), label = "Mean", value = def['Normal', 1], min=0)),
      column(5, numericInput(paste0(id, "_sd"), label = "SD", value = def['Normal', 2], min=0)))),

    conditionalPanel( condition = paste0("input.", id, "_dist == 'LogNormal'"), fluidRow(
      column(1),
      column(5, numericInput(paste0(id, "_meanlog"), label = "log(Mean)", value = def['LogNormal', 1], min=0)),
      column(5, numericInput(paste0(id, "_sdlog"), label = "log(SD)", value = def['LogNormal', 2], min=0)))),

    conditionalPanel( condition = paste0("input.", id, "_dist == 'StudentT'"), fluidRow(
      column(4, numericInput(paste0(id, "_tmean"), label = "Mean", value = def['StudentT', 1], min=0)),
      column(4, numericInput(paste0(id, "_tsd"), label = "SD", value = def['StudentT', 2], min=0)),
      column(4, numericInput(paste0(id, "_tdf"), label = "degree of freedom", value = def['StudentT', 3], min=0)))),

    conditionalPanel( condition = paste0("input.", id, "_dist == 'LogStudentT'"), fluidRow(
      column(4, numericInput(paste0(id, "_ltmeanlog"), label = "log(Mean)", value = def['LogStudentT', 1], min=0)),
      column(4, numericInput(paste0(id, "_ltsdlog"), label = "log(SD)", value = def['LogStudentT', 2], min=0)),
      column(4, numericInput(paste0(id, "_ltdf"), label = "degree of freedom", value = def['LogStudentT', 3], min=0)))),

    conditionalPanel( condition = paste0("input.", id, "_dist == 'Triangle'"), fluidRow(
      column(4, numericInput(paste0(id, "_peak"), label = "Peak", value = def['Triangle', 1], min=0)),
      column(4, numericInput(paste0(id, "_min"), label = "Min", value = def['Triangle', 2], min=0)),
      column(4, numericInput(paste0(id, "_max"), label = "Max", value = def['Triangle', 3], min=0))))
  )
}

updateDistibution <- function(input) {
  d <- data.frame(input$new_name)

  for (n in c("M", "N1", "T")) {
    dist <- input[[paste0(n, "_dist")]]
    d[n] <- dist
    if (dist == "Gamma") {
      d[paste0(n, "_1")] <- input[[paste0(n, "_shape")]]
      d[paste0(n, "_2")] <- input[[paste0(n, "_rate")]]
      d[paste0(n, "_3")] <- NA
    } else if (dist == "Normal") {
      d[paste0(n, "_1")] <- input[[paste0(n, "_mean")]]
      d[paste0(n, "_2")] <- input[[paste0(n, "_sd")]]
      d[paste0(n, "_3")] <- NA
    } else if (dist == "LogNormal") {
      d[paste0(n, "_1")] <- input[[paste0(n, "_meanlog")]]
      d[paste0(n, "_2")] <- input[[paste0(n, "_sdlog")]]
      d[paste0(n, "_3")] <- NA
    } else if (dist == "StudentT") {
      d[paste0(n, "_1")] <- input[[paste0(n, "_tmean")]]
      d[paste0(n, "_2")] <- input[[paste0(n, "_tsd")]]
      d[paste0(n, "_3")] <- input[[paste0(n, "_tdf")]]
    } else if (dist == "LogStudentT") {
      d[paste0(n, "_1")] <- input[[paste0(n, "_ltmeanlog")]]
      d[paste0(n, "_2")] <- input[[paste0(n, "_ltsdlog")]]
      d[paste0(n, "_3")] <- input[[paste0(n, "_ltdf")]]
    }else if (dist == "Triangle") {
      d[paste0(n, "_1")] <- input[[paste0(n, "_peak")]]
      d[paste0(n, "_2")] <- input[[paste0(n, "_min")]]
      d[paste0(n, "_3")] <- input[[paste0(n, "_max")]]
    } else {
      d[paste0(n, "_1")] <- 10
      d[paste0(n, "_2")] <- 1
      d[paste0(n, "_3")] <- NA
    }
  }
  d
}


# Star Wars box office in millions (!)
box <- c(460.998, 314.4, 290.475, 247.900, 309.306, 165.8)

# Create star_wars_matrix
star_wars_matrix<- matrix(box, nrow=3, byrow = TRUE)
print(star_wars_matrix)


juggle <- function(n, s) {
  if (is.na(s[1])) {
    n
  } else if (s[1] == 1) {
    juggle(n * 2^s[2], s[3:length(s)])
  } else {
    juggle((n+1) * 2^s[2] - 1, s[3:length(s)])
  }
}

cat(sapply(lapply(strsplit(readLines(tail(commandArgs(), n=1)), " "), nchar), function(s) {
  toString(juggle(0, s))
}), sep="\n")


library(npowerPrioR)

scenario <- 4

source(paste("data_Bernoulli_scenario_", scenario, ".r", sep = ""))

library(rstan)
rstan_options(auto_write = TRUE)
options(mc.cores = 4)

#### Sampling from the "prior"
prior <- stan_model("stan/simple_Bernoulli_prior.stan")

bb.data <- list(
  N0 = N_0,
  y0 = y_0,
  c = cc,
  d = dd,
  a_0 = NA
)

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

epsilon <- 0.05
J <- 20
maxA <- 1

adaptive.time <- system.time(
  adaptive.ca0.estimates <- build_grid(compiled.model.prior = prior,
                                       eps = epsilon,
                                       M = maxA, J = J, v1 = 10, v2 = 10, stan.list = bb.data, pars = "theta")
)
warnings()

write.csv(adaptive.ca0.estimates$result,
          file = paste("../../data/constant_data/Bernoulli_logCA0_scenario_", scenario,
                       "_J=", J, ".csv", sep = ""), row.names = FALSE)

summaries.adaptive <- adaptive.ca0.estimates$summaries
for (j in 1:length(summaries.adaptive)){
  summaries.adaptive[[j]] <- data.frame(summaries.adaptive[[j]], a_0 = adaptive.ca0.estimates$result$a0[j])
}
summaries.adaptive.dt <- do.call(rbind, summaries.adaptive)

write.csv(summaries.adaptive.dt,
          file = paste("../../data/sensitivity_data/priorSensitivity_simpleBernoulli_adaptive_scenario_", scenario,
          "_J=", J, ".csv", sep = ""))


# Author: Adam L. Rich
# Date:   November 19, 2011
# Description:
#
#   To analyze the ENABLE words set as found in the `words` object of enable.RData
#

load('./enable.RData')

# A function to parse a word into a letter count row
letter.count <- function(word) {
  i.word <- as.integer(factor(strsplit(word, '')[[1]], levels = c.letters))
  r <- tabulate(i.word, 26)
  names(r) <- c.letters
  r
}

# A function to take a string of letters and find all the words that would have those letters or more
letter.match.all <- function(word, w) {
  l <- letter.count(word)
  w[w$a >= l['a'] &
    w$b >= l['b'] &
    w$c >= l['c'] &
    w$d >= l['d'] &
    w$e >= l['e'] &
    w$f >= l['f'] &
    w$g >= l['g'] &
    w$h >= l['h'] &
    w$i >= l['i'] &
    w$j >= l['j'] &
    w$k >= l['k'] &
    w$l >= l['l'] &
    w$m >= l['m'] &
    w$n >= l['n'] &
    w$o >= l['o'] &
    w$p >= l['p'] &
    w$q >= l['q'] &
    w$r >= l['r'] &
    w$s >= l['s'] &
    w$t >= l['t'] &
    w$u >= l['u'] &
    w$v >= l['v'] &
    w$w >= l['w'] &
    w$x >= l['x'] &
    w$y >= l['y'] &
    w$z >= l['z'],]
}

letter.match.any <- function(word, w) {
  l <- letter.count(word)
  w[w$a <= l['a'] &
    w$b <= l['b'] &
    w$c <= l['c'] &
    w$d <= l['d'] &
    w$e <= l['e'] &
    w$f <= l['f'] &
    w$g <= l['g'] &
    w$h <= l['h'] &
    w$i <= l['i'] &
    w$j <= l['j'] &
    w$k <= l['k'] &
    w$l <= l['l'] &
    w$m <= l['m'] &
    w$n <= l['n'] &
    w$o <= l['o'] &
    w$p <= l['p'] &
    w$q <= l['q'] &
    w$r <= l['r'] &
    w$s <= l['s'] &
    w$t <= l['t'] &
    w$u <= l['u'] &
    w$v <= l['v'] &
    w$w <= l['w'] &
    w$x <= l['x'] &
    w$y <= l['y'] &
    w$z <= l['z'],]
}


#getDistanceByMunis <- function(muni1, muni2, map) {

#cacheDistances <- function(

read_mat_csv <- function(option) {
    # Reads a csv file and returns a matrix as a data frame.
    #
    # Args:
    #   option: Use '1' to read joint voting matrix.
    #           Use '2' to read commuting matrix.
    #
    # Returns:
    #   The matrix as a data frame.
    if (option == 1)
	mat <- read.csv("jvp_mat.csv", row.names = 1)
    else if (option == 2)
	mat <- read.csv("comm_mat.csv", row.names = 1)
    else
	stop("Must specify an option.\n1: joint voting patterns\n
	     2: communication patterns")

    return(mat)
}

make_paired_list_from_matrix <- function(mat) {
    # Converts matrix elements to a list of pairs.
    #
    # Args:
    #   mat: The matrix to be converted.
    #
    # Returns:
    #   The paired list of values.

    # make the paired list
    mat_as_paired_list <- as.matrix(mat) # make sure not dframe

    # mat row/col pairs to row/row pairs
    mat_as_paired_list <- melt(mat_as_paired_list)

    return(mat_as_paired_list)
}

append_comm_vals_to_jvp_list <- function(jvp_list, comm_list) {
    # Appends commuting data column to joint voting pattern list.
    #
    # Args:
    #   jvp_list: The joint voting pattern list.
    #   comm_list: The commuting list.
    #
    # Returns:
    #   The merged list containing both jvp and comm data.

    jvp_list <- cbind(jvp_list, comm_list[3])
    return(jvp_list)
}

plot_reg_line <- function(jvp_list) {
    # Generates a scatter plot with a linear regression line.
    #
    # Args:
    #   jvp_list: The list containing muni pairs and their
    #             corresponding jvp and comm data
    #
    # Returns:
    #   Returns NULL.

    comm <- jvp_list[, 4] # comm vec
    jvp <- jvp_list[, 3] # voting vec

    plot(comm, jvp)
    abline(lm(jvp~comm), col = "red")  # regression line (y~x)
    return(NULL)
}

get_elec_data_by_muni <- function(muni, all_elec_data) {
    # Filters election data by municipality.
    #
    # Args:
    #   muni: The muni for which election data is to be obtained.
    #   elec_data: The data frame containing all election data.
    #
    # Returns:
    #   A single-row data frame with the election data for muni.

    current_muni_elec_data <- filter(all_elec_data, MUNI == muni)
    return(current_muni_elec_data)
}

write_similarity_vals <- function(jvp_mat, elec_data) {
    # Writes muni voting data to each matrix element.
    #
    # Args:
    #   jvp_mat: The empty matrix to be filled with voting data.
    #   elec_data: The data frame containing all election data.
    #
    # Returns:
    #   The muni x muni matrix containing joint voting data for each pair.

    for (i in 1:nrow(jvp_mat)) {
	row_name <- rownames(jvp_mat)[i]
	for (j in 1:ncol(jvp_mat)) {

	    col_name <- colnames(jvp_mat)[j]

	    print("current pair is")
	    print(paste(row_name, col_name, sep = ","))

	    muni1 <- get_elec_data_by_muni(row_name, elec_data)
	    muni1_perc_une <- muni1$PERC_UNE[1]

	    muni2 <- get_elec_data_by_muni(col_name, elec_data)
	    muni2_perc_une <- muni2$PERC_UNE[1]

	    # Use this formula to calculate similarity.
	    # V = 100 - |(A_1 - A_2|
	    val <- (100 - abs(muni1_perc_une - muni2_perc_une))

	    jvp_mat[i,j] <- val
	    val <- 0  # can maybe delete this
	}
    }
    return(jvp_mat)
}

# in progress. not yet used
# set a filter here for determining whether two communities are related
is_related <- function(comm1, comm2, mat) {

    if (!is.na(mat[comm1, comm2]))
	return(TRUE)
    else
	return(FALSE)
}

increment_matrix_elems <- function(valid_recs, all_home_recs, mat, k_options) {
    # Iterates through rows of valid_recs and increments matrix elements for
    # each valid call between munis.
    #
    # Args:
    #   valid_recs: The data frame containing all records for which there is
    #               a home assigned to both ANUMBER and BNUMBER.
    #   all_home_recs: The data frame containing home IDs for each ANUMBER
    #   mat: The home_id x home_id empty matrix whose elements are to
    #        be incremented.

    new_mat <- mat

    # for each row
    for (i in 1:nrow(valid_recs)) {
	current_elm <- new_mat[get_home_id(all_home_recs, k_options$k_home_type,
					  as.character(valid_recs$ANUMBER[i])),
	                                  get_home_id(all_home_recs,
						      k_options$k_home_type,
			                  as.character(valid_recs$BNUMBER[i]))]

	# if current elem is na, set to 1.
       if (is.na(current_elm)) {
	   new_mat[get_home_id(all_home_recs, k_options$k_home_type,
			       as.character(valid_recs$ANUMBER[i])),
	                       get_home_id(all_home_recs, k_options$k_home_type,
			       as.character(valid_recs$BNUMBER[i]))] <- 1
       }

       #  otherwise, add 1 to the current value in that element.
       else {
	   new_mat[get_home_id(all_home_recs, k_options$k_home_type,
			       as.character(valid_recs$ANUMBER[i])),
	                       get_home_id(all_home_recs, k_options$k_home_type,
			       as.character(valid_recs$BNUMBER[i]))] <-
			       new_mat[get_home_id(all_home_recs,
						   k_options$k_home_type,
			       as.character(valid_recs$ANUMBER[i])),
	                       get_home_id(all_home_recs, k_options$k_home_type,
			       as.character(valid_recs$BNUMBER[i]))] + 1
       }
    }

   df <- as.data.frame(new_mat)

   return(df)
}

# Remove cols in a df which are all NA
remove_cols_with_all_nas <- function(df) {
   return(df[, !(colSums(is.na(df)) == NROW(df))])
}

# Remove rows in a df which are all NA
remove_rows_with_all_nas <- function(df) {
   return(df[!(rowSums(is.na(df)) == NCOL(df)), ])
}

get_recs_with_known_homes <- function(valid_bnum_recs, all_anum_recs) {
    # Creates a data frame containing only records for which there is a home_id for
    # both ANUMBER and BNUMBER.
    #
    # Args:
    #   valid_bnum_recs: The data frame containing records for which there is
    #                    a home_id for each BNUMBER.
    #   all_anum_recs: The data frame containing all ANUMBER records for which
    #                  there is a home_id for each ANUMBER.
    # Returns:
    #   The data frame containing all valid records.

    valid_recs <- all_anum_recs %>%
	filter(grepl(paste(valid_bnum_recs$ANUMBER, collapse = "|"),
		     all_anum_recs$BNUMBER))

    return(valid_recs)
}

filter_by_bnum_in_a <- function(home_recs) {
    # Creates a data frame where all BNUMBERS are present
    # as ANUMBERs in the CDR.
    #
    # Args:
    #   home_recs: The filtered CDR containing all ANUMBERS
    #              and their home_ids.
    #
    # Returns:
    #   The data frame containing all valid BNUMBER records.

    valid_bnum_recs <- home_recs %>%
	filter(grepl(paste(home_recs$BNUMBER, collapse="|"),
		     home_recs$ANUMBER))

    return(valid_bnum_recs)
}

get_all_home_recs <- function(home_ids, cdr) {
    # Creates a filtered data frame containing all records for each number.
    #
    # Args:
    #   home_ids: The data frame of unique ANUMBERS which have homes assigned.
    #   cdr: The imported call detail records containing all call records.
    #
    # Returns:
    #   The filtered data frame with only records which have home_ids assigned.

    fcdr <- cdr %>%
	filter(grepl(paste(home_ids$ANUMBER, collapse = "|"), cdr$ANUMBER))

    return(fcdr)
}

get_unique_labels <- function(elec_data, k_options) {
    # Creates a data frame of the set of unique home_ids
    # (home_id can be tower, muni, or department -- specified by user).
    #
    # Args:
    #   elec_data: The data frame containing all election data.
    #   k_options: The data frame containing a set of user-defined constants.
    #
    # Returns:
    #   The vector containing all of the unique home_ids.

    # if home_id is tower
    if (k_options$k_home_type == 1) {
	stop("getUniqueMunis() not yet defined for this category")
    }

    # if home_id is muni
    else if (k_options$k_home_type == 2) {
	unique_labels <- unique(elec_data$MUNI)
	return(unique_labels)
    }

    # if home_id is dept
    else if (k_options$k_home_type == 3) {
	unique_labels <- unique(elec_data$DEPT)
	return(unique_labels)
    }
}

create_jvp_matrix <- function(elec_data, k_options) {
    # Creates an empty home_id x home_id matrix using all unique labels of that
    # home_id type (defined by user).
    #
    # Args:
    #   elec_data: The data frame containing all election data.
    #   k_options: The data frame containing a set of user-defined constants.
    #
    # Returns:
    #   The empty home_id x home_id data frame.

    unique_labels <- get_unique_labels(elec_data, k_options)
    n <- length(unique_labels)

    jvp_mat <- matrix(, nrow = n, ncol = n)

    colnames(jvp_mat) <- unique_labels[1:ncol(jvp_mat)]
    rownames(jvp_mat) <- unique_labels[1:nrow(jvp_mat)]

    return(jvp_mat)
}

# NOTE TO SELF: NOT USED. DELETE?
get_unique_home_ids <- function(dframe) {
    # Gets the
    unique_homes <- unique(dframe$HOME_ID)
    return(unique_homes)
}

# NOTE TO SELF: NOT USED. DELETE?
# create an NxN labeled matrix where N is HOME_ID
create_home_id_matrix <- function(dframe) {
    unique_homes <- get_unique_home_ids(dframe)
    n <- length(unique_homes)

    mat <- matrix(, nrow = n, ncol = n)

    colnames(mat) <- unique_homes[1:ncol(mat)]
    rownames(mat) <- unique_homes[1:nrow(mat)]

    return(mat)
}

# NOTE TO SELF: NOT USED. DELETE?
# create a dframe of only records with home addresses
get_all_home_ids <- function(data, towers, threshs) {

  print("Removing records with no home/work pairs...")
  orig_num <- nrow(data)  # get orig_num records

  filt_cdr <- show_home_and_work_towers(data, towers, threshs) %>%
    filter(!is.na(HOME_ID) & (HOME_ID != ("TO BE DETERMINED")))
  filt_cdr$WORK_ID <- NULL

  # get new_num records after removing records w/o home and work locs
  new_num <- nrow(filt_cdr)

  print(paste("raw data: ", orig_num, " record(s)", sep = ""))
  print(paste("filtered data: ", new_num, " record(s)", sep = ""))
  print(paste("percentage removed", 100 - (orig_num / new_num)))

  return(filt_cdr)
}

load_sources <- function() {
    print("Loading sources")
    source("../../commuting/src/commuterCategorize.r")
    print("Success")
}

make_binary_matrix <- function(mat) {
    # Makes a binary matrix from a given matrix input.
    #
    # Args:
    #   mat: The matrix whose values are to be changed to 1 (if data).
    #
    # Returns:
    #   The binary matrix.

    # change all values >= 1 to 1 to make binary
    mat[] <- + (mat >= 1)

    return(mat)
}

# reads raw data and generates csv files for comm and jvp
main_mapping <- function() {
    # Loads all data and writes jvp and comm matrices to csv files.
    #
    # Args:
    #   none.
    #
    # Returns:
    #   0 if success.

    load_sources()
    load_packs()

    # init constant vals
    k_options <- set_options()
    data_list <- get_data(init_paths())

    cdr <- data_list$cdr
    towers <- data_list$towers
    elec_data <- data_list$elec_data

    orig_numm_recs <- nrow(cdr)

    home_ids <- find_and_remove_records_with_no_home(cdr, towers, k_options)

    # CDR with all ANUMS who have homes
    all_home_recs <- get_all_home_recs(home_ids, cdr)

    # return a dframe where all BNUMBERS also present as ANUMBER
    valid_bnum_recs <- filter_by_bnum_in_a(all_home_recs)
    valid_recs <- get_recs_with_known_homes(valid_bnum_recs, all_home_recs)
    num_valid_recs <- nrow(valid_recs)

    print(paste("Original number of records: ", orig_numm_recs))
    print(paste("Number of records for which there exist home_ids and an ANUMBER
		for every BNUMBER: ", num_valid_recs))
    print(paste("Percentage removed: ",
		100 - (num_valid_recs / orig_numm_recs)))

    jvp_mat <- create_jvp_matrix(elec_data, k_options)
    home_id_mat <- jvp_mat

    # increment matrix elems: +1 for each call between communities
    inc_mat <- increment_matrix_elems(valid_recs, home_ids, home_id_mat, k_options)
    binary_mat <- make_binary_matrix(inc_mat)

    # write vals into jvp_mat
    jvp_mat <- write_similarity_vals(jvp_mat, elec_data)

    # write to csv file
    write.table(jvp_mat, file = "jvp_mat.csv",
		row.names = TRUE, col.names = NA, sep = ",")
    write.table(binary_mat, file = "comm_mat.csv",
		row.names = TRUE, col.names = NA, sep = ",")

    return(0)
}


# Team Rython: Dainius Masiliunas and Tim Weerman
# January 12, 2016
# Apache License 2.0

library(raster)

# Clear the environment
rm(list = ls())
## NB: Make sure your working directory is in Lesson7
getwd()

source("src/GetGreennessIndex.r")
source("src/PlotGreenestCity.r")

# Get NDVI data
download.file("https://github.com/GeoScripting-WUR/VectorRaster/raw/gh-pages/data/MODIS.zip", destfile="data/modis.zip", method="wget")
unzip("data/modis.zip", exdir="data")
ModisData = brick(list.files("data", pattern=glob2rx('*.grd'), full.names=TRUE))

# Sanitise data
ModisData[ModisData < 0] = NA

# Get administrative data
NLadm <- getData('GADM', country='NLD', level=2, path="data")

# Reproject vector to raster CRS
NLadm = spTransform(NLadm, CRS(proj4string(ModisData)))

# Repeat for provinces
NLpro <- getData('GADM', country='NLD', level=1, path="data")
NLpro = spTransform(NLpro, CRS(proj4string(ModisData)))

# Find the greenest city!
# Note: a lot of data to process, this may take a while!
FindGreenestCity(ModisData, NLadm, 1) # January
FindGreenestCity(ModisData, NLadm, 8) # August
FindGreenestCity(ModisData, NLadm, 1:12) # The whole year

# Finds greenest provinces instead:
FindGreenestCity(ModisData, NLpro, 1) # January
FindGreenestCity(ModisData, NLpro, 8) # August
FindGreenestCity(ModisData, NLpro, 1:12) # The whole year


# H0: None == BGP
# Compare means with one-way ANOVA

## Bloom
data <- read.csv('../../results_old/filter_types/data_all.csv', sep = ';')

data <- data[which(data$combination=='combination_0' | data$combination=='combination_4'),]
print(data)

kruskal.test(combination ~ time, data = data)

#t.test(data$combination_0, data$combination_4,paired=TRUE)
#kruskal.test(combination_1 ~ combination_5, data = data)
# p: 0.5265
# => Accept H0, equal means
#mean(data$combination_0) # 12500.69
#mean(data$combination_4) # 16917.35
# None == BGP !

## GCS
#t.test(data$combination_1, data$combination_5,paired=TRUE)
# p: 0.6731
# => Accept H0, equal means
#mean(data$combination_1) # 13250.39
#mean(data$combination_5) # 16145.51
# None == BGP !


library(class)
nb<-naiveBayes(Species~.,iris)
table(predict(nb,iris[,-5]),iris[,5])
pairs(iris[1:4],main="Iris Data (red=setosa,green=versicolor,blue=virginica)",pch=21, bg= c("red", "green3", "blue")[unclass(iris$Species)])
n=dim(iris)[1]
index=sample(n,0.7*n)
appren=iris[index,]
test=iris[-index,]
nb.model <- naiveBayes(Species~.,data=appren)
pred=predict(object=nb.model,newdata=test)
test.mod<-cbind(test,pred)
head(test.mod,5)
confusion=table(test.mod$Species,test.mod$pred)
round(prop.table(confusion),2)


#' @title Fitting bivariate MGL copula models for mixed data
#' @description \code{MGL.mle.mixed} is used to fit bivariate mixed copula regression models via maximum likelihood (ML) method for continuous and semi-continuous variables.
#' @param U two-dimenstional matrix for pseudo copula data with values in \eqn{[0,1]} for (F(y1), F(y2)).
#' @param copula copula 'MGL', 'MGL180', "MGL-EV", "MGL-EV180", "MGB2", "Normal" , "t".
#' @param hessian Logical. Should a numerically differentiated Hessian matrix be returned?
#' @param initpar Initial values for the parameters to be optimized over.
#' @param U_ two-dimensional matrix for pseudo copula data for the data (F(y1), F(y2-1)).
#' @param obs two-dimensional matrix for loss observations (y1, y2).
#' @param f values of the density function for marginal distribution.
#' @param umin threshold value used in the semi-continuous data.
#' @param ... additional arguments, see \code{\link[stats]{nlm}} for more details.
#' @importFrom stats nlm
#' @md
#' @return A list containing the following components:
#' * loglike: the value of the estimated maximum of the loglikelihood function.
#' * copula: the name of the fitted copula. "MGL180" and "MGL-EV180" denote the survival MGL and MGL-EV copula respectively.
#' * estimates: the point at which the maximum value of the loglikelihood is obtained.
#' * se: the standard errors of the estimators.
#' * AIC, BIC: the goodness fit of the regression models.
#' * hessian: the hessian at the estimated maximum of the loglikelihood (if requested).
#'
#' @details
#' The estimation method is performed via \code{\link[stats]{nlm}} function.
#' Y1: continuous variable
#' Y2: semi-continuous variable when Y2>umin, it is continuous and Y2<=umin is discrete.
#'
#' For a portfolio of \eqn{n} observations \eqn{(y_{i1},y_{i2}; \; i=1,\ldots,n)}, the joint density function of \eqn{(Y_1,Y_2)} can be written as
#' \deqn{
#' 	f_{Y_{1},Y_2}(y_{i1},y_{i2})=\begin{cases}
#' 	f_{Y_1}(y_{i1})[
#' 	h_{2|1}(F_{Y_{1}}(y_{i1}),F_{Y_{2}}(y_{i2})) - h_{2|1}(F_{Y_{1}}(y_{i1}),F_{Y_{2}}(y_{i2}-1))
#' 	], & y_{i2}\le umin,\\
#' 	f_{Y_1}(y_{i1})f_{Y_2}(y_{i2})c(F_{Y_{1}}(y_{i1}), F_{Y_{2}}(y_{i2})), & y_{i2} > umin,
#' 	\end{cases}
#' }
#' where the density \eqn{f_{Y_j}(\cdot)} and cdf \eqn{F_{Y_j}(\cdot)} of the marginal distributions  (\eqn{i=1,2}) are specified respectively. Here
#' \eqn{h_{2|1}(u_1, u_2)=\partial C(u_1,u_2)/\partial u_1} is the \eqn{h}-function of bivariate copula.
#'
#'
#' copula:
#' * "MGB2" is multivariate GB2.
#' * "Normal" and "t" denote the Gaussian copula and Student-t copula respectively.
#' * "MGL" and "MGL-EV" denote the MGL and MGL-EV copula respectively.
#' * "MGL180" and "MGL-EV180" denote the survival MGL and survival MGL-EV copula respectively.
#' * "Gumbel" is Gumbel copula.#'
#'
#' @examples
#' library(rMGLReg)
#' # load the Chinese earthquake data set
#' u <- cbind(earthqCHI$u1, earthqCHI$u2) # cdf of marginal distribution
#' u_ <- cbind(earthqCHI$u1, earthqCHI$u2_) # cdf of marginal distribution for Y1 and Y2 - 1
#' y <- cbind(earthqCHI$y1, earthqCHI$y2)  # observations
#' f <- cbind(earthqCHI$f1, earthqCHI$f2) # pdf of marginal distribution
#' obs <- y
#' U <- u
#' U_ <- u_
#' umin <- 20
#' m.MGLMGA180 <- MGL.mle.mixed(obs = y, U = U, U_ = U_,
#' umin = umin, f = f,
#' copula = "MGL180",
#' method = "L-BFGS-B", initpar = c(2))
#' m.MGLMGA180
#' @export
#'
MGL.mle.mixed <- function(obs, U, U_, f, copula = c(
                            "MGL", "MGL180", "MGL-EV",
                            "MGL-EV180",
                            "Gumbel",
                            "Normal", "MGB2", "t"
                          ), umin,
                          hessian = TRUE,
                          initpar, ...) {
  dnormcop <- function(U, param) {
    as.numeric(fCopulae::dellipticalCopula(U, rho = param[1], type = "norm"))
  } # normal copula

  dtcop <- function(U, param) {
    as.numeric(fCopulae::dellipticalCopula(U,
      rho = param[1], type = "t",
      param = param[2]
    ))
  } # t copula

  dgumcop <- function(U, param) {
    as.numeric(fCopulae::devCopula(U, type = "gumbel", param = param[1]))
  } # Bivariate Extreme

  dMGL <- function(U, param) {
    as.numeric(dcMGL.bivar(u1 = U[, 1], u2 = U[, 2], pars = param[1]))
  }

  dMGL180 <- function(U, param) {
    as.numeric(dcMGL180.bivar(u1 = U[, 1], u2 = U[, 2], pars = param[1]))
  }

  dMGB2 <- function(U, param) {
    as.numeric(dcMGB2.bivar(u1 = U[, 1], u2 = U[, 2], pars1 = param[1], pars2 = param[2], pars3 = param[3]))
  }

  dMGLEV <- function(U, param) {
    as.numeric(dcMGLEV.bivar(u1 = U[, 1], u2 = U[, 2], param = param[1])) # Bivariate Extreme
  }

  dMGLEV180 <- function(U, param) {
    as.numeric(dcMGLEV180.bivar(u1 = U[, 1], u2 = U[, 2], param = param[1])) # Bivariate Extreme
  }

  hnormcop <- function(U, param) {
    VineCopula::BiCopHfunc(U[, 1], U[, 2], family = 1, par = param[1])
  }
  htcop <- function(U, param) {
    VineCopula::BiCopHfunc(U[, 1], U[, 2], family = 2, par = param[1], par2 = param[2])
  }
  hgumcop <- function(U, param) {
    VineCopula::BiCopHfunc(U[, 1], U[, 2], family = 4, par = param[1])
  }
  hMGL <- function(U, param) {
    hcMGL.bivar(u1 = U[, 1], u2 = U[, 2], pars = param[1])
  }
  hMGL180 <- function(U, param) {
    hfunc1 <- 1 - hcMGL.bivar(u1 = 1 - U[, 1], u2 = 1 - U[, 2], pars = param[1])$hfunc1
    hfunc2 <- 1 - hcMGL.bivar(u1 = 1 - U[, 1], u2 = 1 - U[, 2], pars = param[1])$hfunc2
    out <- list(hfunc1 = hfunc1, hfunc2 = hfunc2)
    out
  }
  hMGLEV180 <- function(U, param) {
    hfunc1 <- hcMGLEV180.bivar(u1 = U[, 1], u2 = U[, 2], param = param[1])$hfunc1
    hfunc2 <- hcMGLEV180.bivar(u1 = U[, 1], u2 = U[, 2], param = param[1])$hfunc2
    out <- list(hfunc1 = hfunc1, hfunc2 = hfunc2)
    out
  }
  hMGLEV <- function(U, param) {
    hfunc1 <- 1 - hcMGLEV180.bivar(u1 = 1 - U[, 1], u2 = 1 - U[, 2], param = param[1])$hfunc1
    hfunc2 <- 1 - hcMGLEV180.bivar(u1 = 1 - U[, 1], u2 = 1 - U[, 2], param = param[1])$hfunc2
    out <- list(hfunc1 = hfunc1, hfunc2 = hfunc2)
    out
  }
  hMGB2 <- function(U, param) {
    hcMGB2.bivar(u1 = U[, 1], u2 = U[, 2], pars1 = param[1], pars2 = param[2], pars3 = param[3])
  }

  argnorm <- list(length = 1, lower = 0, upper = 1, name = "Gaussian")
  argt <- list(length = 2, lower = c(0, 0), upper = c(1, 100), name = "Student")
  arggum <- list(length = 1, lower = 1, upper = 50, name = "Gumbel")
  argMGB2 <- list(length = 3, lower = c(0, 0, 0), upper = c(50, 50, 50), name = "MGB2")
  argMG180 <- list(length = 1, lower = 0, upper = 10, name = "MGL180")
  argMGLEV180 <- list(length = 1, lower = 0, upper = 10, name = "MGL-EV180")
  argMG <- list(length = 1, lower = 0, upper = 10, name = "MGL")
  argMGLEV <- list(length = 1, lower = 0, upper = 10, name = "MGL-EV")
  if (copula == "MGL") {
    dcop <- dMGL
    arg.cop <- argMG
    hcop <- hMGL
  } else if (copula == "MGL180") {
    dcop <- dMGL180
    arg.cop <- argMG180
    hcop <- hMGL180
  } else if (copula == "MGL-EV") {
    dcop <- dMGLEV
    arg.cop <- argMGLEV
    hcop <- hMGLEV
  } else if (copula == "MGL-EV180") {
    dcop <- dMGLEV180
    arg.cop <- argMGLEV180
    hcop <- hMGLEV180
  } else if (copula == "Gumbel") {
    dcop <- dgumcop
    arg.cop <- arggum
    hcop <- hgumcop
  } else if (copula == "Normal") {
    dcop <- dnormcop
    arg.cop <- argnorm
    hcop <- hnormcop
  } else if (copula == "t") {
    dcop <- dtcop
    arg.cop <- argt
    hcop <- htcop
  } else if (copula == "MGB2") {
    dcop <- dMGB2
    arg.cop <- argMGB2
    hcop <- hMGB2
  }

  # Obs1 <- obs[, 1] # y1
  Obs2 <- obs[, 2] # y2
  f1 <- f[, 1]
  f2 <- f[, 2]
  copLogL <- function(x) {
    if (all(arg.cop$lower < x && arg.cop$upper > x)) {
      index1 <- which(Obs2 <= umin)
      index2 <- which(Obs2 > umin)
      m1 <- f1[index1] * (hcop(U[index1, ], param = x)$hfunc1 - hcop(U_[index1, ], param = x)$hfunc1)
      logL1 <- (log(m1))
      m2 <- f1[index2] * f2[index2] * dcop(U[index2, ], param = x)
      logL2 <- (log(m2))
      ll <- c(logL1, logL2)
      res <- -sum((ll)) # define the loglikelihood
    } else {
      res <- 100000000000000000
    }
    return(res)
  }

  resopt <- nlm(
    f = copLogL,
    p = initpar,
    hessian = hessian
  )

  # list(
  #   loglike = -resopt$minimum,
  #   copula = list(name = arg.cop$name),
  #   estimates = resopt$estimate,
  #   se = sqrt(diag(solve(resopt$hessian))),
  #   hessian = -resopt$hessian,
  #   AIC = 2 * length(resopt$estimate) + 2 * resopt$minimum,
  #   BIC = log(nrow(U)) * length(resopt$estimate) + 2 * resopt$minimum
  # )
  # resopt
  if (hessian == TRUE){
    out <-   list(
      loglike = -resopt$minimum,
      copula = list(name = arg.cop$name),
      estimates = resopt$estimate,
      se = sqrt(diag(solve(resopt$hessian))),
      hessian = -resopt$hessian,
      AIC = 2 * length(resopt$estimate) + 2 * resopt$minimum,
      BIC = log(nrow(U)) * length(resopt$estimate) + 2 * resopt$minimum
    )
  } else {
    out <-   list(
      loglike = -resopt$minimum,
      copula = list(name = arg.cop$name),
      estimates = resopt$estimate,
      AIC = 2 * length(resopt$estimate) + 2 * resopt$minimum,
      BIC = log(nrow(U)) * length(resopt$estimate) + 2 * resopt$minimum
    )
  }
  out
}


pacman::p_load(foreign)

rmse <- function(actual, predicted){
  sqrt(mean((actual - predicted)^2))
}

wczytaj_imports_85 <- function(){
  imports = read.csv("imports-85.csv")
  #summary(imports)

  imports$symboling = as.factor(imports$symboling)
  imports$make = as.factor(imports$make)
  imports$fuel.type = as.factor(imports$fuel.type)
  imports$aspiration = as.factor(imports$aspiration)
  imports$num.of.doors = as.factor(imports$num.of.doors)
  imports$body.style = as.factor(imports$body.style)
  imports$drive.wheels = as.factor(imports$drive.wheels)
  imports$engine.location = as.factor(imports$engine.location)
  imports$engine.type = as.factor(imports$engine.type)
  imports$fuel.system = as.factor(imports$fuel.system)
  #summary(imports)

  #hist(imports$normalized.losses,breaks = 50) #wybieram mediane bo nie jest rozk?ad normalny
  imports$normalized.losses[which(is.na(imports$normalized.losses))] = median(imports$normalized.losses, na.rm = T)

  #summary(imports)
  #table(imports$body.style[which(is.na(imports$num.of.doors))])
  imports$num.of.doors[which(is.na(imports$num.of.doors))] = as.factor("four") #wybieram 4 poniewa? wi?kszo?? aut tego typu jest 4-drzwiowe

  #hist(imports$bore,breaks = 50)#wybieram mediane bo nie jest rozk?ad normalny
  imports$bore[which(is.na(imports$bore))] = median(imports$bore, na.rm = T)

  #summary(imports)
  #hist(imports$stroke,breaks = 50)#wybieram mediane bo nie jest rozk?ad normalny
  imports$stroke[which(is.na(imports$stroke))] = median(imports$stroke, na.rm = T)

  #hist(imports$horsepower,breaks = 50)#wybieram mediane bo nie jest rozk?ad normalny
  imports$horsepower[which(is.na(imports$horsepower))] = median(imports$horsepower, na.rm = T)

  #summary(imports)
  #hist(imports$peak.rpm,breaks = 50)#wybieram mediane bo nie jest rozk?ad normalny
  imports$peak.rpm[which(is.na(imports$peak.rpm))] = median(imports$peak.rpm, na.rm = T)

  #hist(imports$price, breaks = 50)#wybieram mediane bo nie jest rozk?ad normalny
  imports$price[which(is.na(imports$price))] = median(imports$price, na.rm = T)
  set.seed(123)

  imports = as.data.frame(sapply(imports, as.numeric))#zmiana na numeryczne i "ramke"

  indexy <- sample(nrow(imports), size = trunc(0.25* nrow(imports)) )
  train <- imports[indexy, ]
  test <- imports[-indexy, ]

  #eliminacja zmiennych
  tmp <- lm(symboling~1, data = train)
  forward = step(tmp, direction = "forward", scope = list(upper=.~.+ horsepower + `normalized.losses` + make + `fuel.type` + aspiration + `num.of.doors` + `body.style` + `drive.wheels` + `engine.location` + `wheel.base` + length + width + height + `curb.weight` + `engine.type` + `num.of.cylinders` + `engine.size` + `fuel.system` + bore + stroke + `compression.ratio` + price + `peak.rpm` + `city.mpg` + `highway.mpg`), trace=0)
  summary(forward)$r.squared#0.7512137

  tmp <- lm(symboling~horsepower+`normalized.losses`+make+`fuel.type`+aspiration+`num.of.doors`+`body.style`+`drive.wheels`+`engine.location`+`wheel.base`+length+width+height+`curb.weight`+`engine.type`+`num.of.cylinders`+`engine.size`+`fuel.system`+bore+stroke+`compression.ratio`+price+`peak.rpm`+`city.mpg`+`highway.mpg`, data = train)
  backward = step(tmp, direction = "backward", scope = list(upper=.~.+ horsepower + `normalized.losses` + make + `fuel.type` + aspiration + `num.of.doors` + `body.style` + `drive.wheels` + `engine.location` + `wheel.base` + length + width + height + `curb.weight` + `engine.type` + `num.of.cylinders` + `engine.size` + `fuel.system` + bore + stroke + `compression.ratio` + price + `peak.rpm` + `city.mpg` + `highway.mpg`), trace=0)
  summary(backward)$r.squared#0.8202633

  tmp <- lm(symboling~. , data = imports)
  both <- step(tmp, direction = "both", scope = list(upper=.~.+ horsepower + `normalized.losses` + make + `fuel.type` + aspiration + `num.of.doors` + `body.style` + `drive.wheels` + `engine.location` + `wheel.base` + length + width + height + `curb.weight` + `engine.type` + `num.of.cylinders` + `engine.size` + `fuel.system` + bore + stroke + `compression.ratio` + price + `peak.rpm` + `city.mpg` + `highway.mpg`), trace=0)
  summary(both)$r.squared#0.7014353

  nazwyKolumn <- variable.names(backward) #najlepszy forward - najwyższy r.squared
  nazwyKolumn[1] <- "symboling" #poprawka nazwy

  return(list("columns" = nazwyKolumn, "train" = train, "test"=test))
}

svm_imports <- function(kolumny, dane, kernel = "radial"){
  model = svm(symboling~., data=dane[,kolumny], kernel = kernel, type="nu-regression")
  return (model)
}

# pacman::p_load(corrplot)
# imports.cor <- sapply(imports,function(x) as.numeric(x))
# cor_matrix=cor(imports.cor)
# corrplot.mixed(cor_matrix)


###############################################################################
# Hierarchical Clustering and Plotting
#------------------------------------------------------------------------------
# based on Umer Zeeshan Ijaz (http://userweb.eng.gla.ac.uk/umer.ijaz)
###############################################################################

# install.packages('ggplot2')
# install.packages('ggdendro')
# install.packages('vegan')

#==============================================================================
# LIBRARY DEPENDENCE
#==============================================================================
library(ggplot2)
library(ggdendro)
library(vegan)

#==============================================================================
# Let's rock'n'roll!
#==============================================================================
# Load the abundance table
abund_table <- read.csv("..//Data//SPE_pitlatrine.csv",
					row.names = 1, check.names = FALSE)

# Transpose the data to have sample names on rows
abund_table <- t(abund_table)

# Get grouping information
grouping_info <- data.frame(row.names = rownames(abund_table),
				t(as.data.frame(strsplit(rownames(abund_table), "_"))))
head(grouping_info)

betad <- vegdist(abund_table, method = "bray")

# Use Adonis to test for overall differences
res_adonis <- adonis(betad ~ X1, grouping_info)

# Cluster the samples
hc <- hclust(betad)

#==============================================================================
# Plots
#==============================================================================

# We will color the labels according to countries(group_info[, 1])
hc_d <- dendro_data(as.dendrogram(hc))
hc_d$labels$Type <- grouping_info[as.character(hc_d$labels$label), 1]

# Coloring function
gg_color_hue <- function(n){
 hues = seq(15, 375, length = n+1)
 hcl(h = hues, l = 65, c = 100)[1:n]
}

cols = gg_color_hue(length(unique(hc_d$labels$Type)))
hc_d$labels$color = cols[hc_d$labels$Type]

p1 <- ggplot(data = segment(hc_d)) +
 geom_segment(aes(x = x, y = y, xend = xend, yend = yend)) +
 coord_flip() +
 scale_x_discrete(labels = label(hc_d)$label) +
 ylab("Distance (beta diversity = bray)") + theme_bw()+
 theme(axis.text.y = element_text(color = hc_d$labels$color),
 axis.title.y = element_blank())
p1 <- p1 + geom_point(data = hc_d$label, aes(x = x, y = y, color = Type),
		inherit.aes = F, alpha = 0)
p1 <- p1 + guides(colour = guide_legend(override.aes =
		list(size = 3, alpha = 1)))+
		scale_color_manual(values = cols)
pdf("Cluster.pdf", height = 10)
print(p1)
dev.off()

Cluster_Analysis/Hierarchical Clustering and Plotting.r


## Instructions to run your output files in R manually (with vegan package)

## You will need the following files (output from two-way_permanova.sh):
##	1) map.vegan.txt (metadata file)
##	2) dm.vegan.txt (distance matrix file)

## Open R
R

## Load vegan
library(vegan)

## Read in your files
map <- read.csv("map.vegan.txt", sep="\t", header=TRUE)
dm0 <- read.csv("dm.vegan.txt", sep="\t", header=TRUE)
dm <- as.dist(dm0)
dmname="dm.vegan.txt"

## List available factors from your metadata
colnames(map)

## Read in your factors
f1 <- map[,"Moisture"] ## if first factor is Moisture
f2 <- map[,"Drought"] ## if second factor is Drought

## Run adonis (permanova) and print to screen
pm <- adonis(formula = dm ~ f1 * f2, permutations = 99)
pm

## Combine your factors for betadisper
f3 <- paste(f1, f2)

## Run betadisper and print to screen
pd <- betadisper(dm, f3)
pd

## Run permutation test of dispersions and print to screen
permutest(pd, permutations = 99)

## Run Tukey HSD test on dispersions and print to screen
pd.HSD <- TukeyHSD(pd)
pd.HSD

## Make PCoA and boxplots
plot(pd, label.cex=0.5, ellipse=TRUE, hull=FALSE, seg.lty="dashed", cex=0.5, sub=dmname, main="PCoA axes 1 vs 2", cex.main=1.5, cex.sub=1.25, cex.lab=1.1, axes=c(1,2))
plot(pd, label.cex=0.5, ellipse=TRUE, hull=FALSE, seg.lty="dashed", cex=0.5, sub=dmname, main="PCoA axes 1 vs 3", cex.main=1.5, cex.sub=1.25, cex.lab=1.1, axes=c(1,3))
plot(pd, label.cex=0.5, ellipse=TRUE, hull=FALSE, seg.lty="dashed", cex=0.5, sub=dmname, main="PCoA axes 2 vs 3", cex.main=1.5, cex.sub=1.25, cex.lab=1.1, axes=c(2,3))
boxplot(pd, main="Boxplots of multivariate dispersions", sub="Categories", cex.axis=0.75, cex.main=1.5, cex.sub=1.25, cex.lab=1.25)

## See the official vegan documentation and tutorials for more functionality:
## https://cran.r-project.org/web/packages/vegan/vegan.pdf
## https://cran.r-project.org/web/packages/vegan/vignettes/intro-vegan.pdf
## http://cc.oulu.fi/~jarioksa/opetus/metodi/vegantutor.pdf


#missing data model.
#fits a global level predictor for each independent variable.
#global level predictor is site level prior.
#site level estimate is plot level prior.
#plot level estimate is core level prior.
#if core level estimate is absent it is drawn from site level estimate.

#load some core level data missing at core and plot scale.
rm(list=ls())

#load data
d <- readRDS('/fs/data3/caverill/NEFI_microbial/NEON_data_aggregation/core.table.rds')
d <- d[d$siteID %in% c('ORNL','DSNY'),]           #subset to two sites for development.
y <- as.matrix(d[,c('soilTemp','soilInWaterpH')]) #matrix of x values.

#drop factor levels. Important when subsetting to a few sites.
d$siteID <-droplevels(d$siteID)
d$plotID <-droplevels(d$plotID)

#setup categorical predictor matrices.
plot.preds <- model.matrix( ~ plotID - 1, data = d)
site.preds <- model.matrix( ~ siteID - 1, data = d)

#indexing.
plot_plot <- as.factor(unique(d$plotID))
plot_site <- as.factor(substr(plot_plot,1,4))

jags.model = "
model {
  #priors
  for(j in 1:N.x){
  glob[j] ~ dnorm(0,1.0E-4) #global level parameter prior.
    for(k in 1:n.site.preds){site[k,j] <- glob[j]}              #prior on site level parameters is glob level parameter.
    for(k in 1:n.plot.preds){plot[k,j] <- site[plot_site[k],j]} #prior on plot level parameters is site level parameter.
     sigma[j] ~ dunif(0, 100)
  glob.tau[j] <- pow(sigma[j], -2)
  site.tau[j] <- pow(sigma[j], -2)
  plot.tau[j] <- pow(sigma[j], -2)
  core.tau[j] <- pow(sigma[j], -2)
  }

  #combine priors and parameters
  for(j in 1:N.x){
    for(i in 1:N){
      glob.x[i,j] ~ dnorm(glob[j],glob.tau[j])
    site.hat[i,j] <- inprod(site[,j], site.preds[i,])
    plot.hat[i,j] <- inprod(plot[,j], plot.preds[i,])
      site.x[i,j] ~ dnorm(site.hat[i,j], site.tau[j])
      plot.x[i,j] ~ dnorm(plot.hat[i,j], plot.tau[j])
      core.x[i,j] ~ dnorm(  plot.x[i,j], core.tau[j]) #predict missing core values based on plot estimate.
    }
  }

} #end model
"
jags.data <- list(core.x = y,
                  plot.preds=plot.preds, site.preds=site.preds,
                  plot_site = plot_site,
                  n.plot.preds = ncol(plot.preds), n.site.preds = ncol(site.preds),
                  N.x = ncol(y), N = nrow(d))

jags.out <- runjags::run.jags(jags.model,
                              data = jags.data,
                              n.chains = 3,
                              monitor = c('plot','site','core.x'))

#check estiamted values of temp and pH.
out <- summary(jags.out)
core.vals <- out[grep('core.x',rownames(out)),]
temp.new <- core.vals[grep(',1]',rownames(core.vals)),]
  pH.new <- core.vals[grep(',2]',rownames(core.vals)),]
temp <- data.frame(d$soilTemp,d$plotID,temp.new[,1:4])
  pH <- data.frame(d$soilInWaterpH,d$plotID,  pH.new[,1:4])

testing_development/ddirch_development/missing data model development.r


library(limma)

setwd("H:/shengquanhu/projects/VANGARD/20180327_rachelle_microarray")

pdata<-read.table("Expression data from Connolly 3.26.18.txt", header=T)

cdata<-pdata[,c(-1,-2)]
adata<-avereps(cdata, ID=pdata$ProbeName)

Patient=as.factor(gsub(".p.*", "", colnames(adata)))
Post=as.factor(grepl("post", colnames(adata)))
design <- model.matrix(~Patient+Post)
fit <- lmFit(adata, design)
fit <- eBayes(fit)
tp<-topTable(fit, coef="PostTRUE", number=nrow(fit))

norep<-pdata[,c(1,2)]
norep<-norep[!duplicated(norep$ProbeName),]
rownames(norep)<-norep$ProbeName

tp$Gene<-norep[rownames(tp),"GeneName"]

write.csv(tp, file="20180327_rachelle_microarray.csv")


library(ggplot2)

ggplot(iris, aes(x = Sepal.Width, y = Sepal.Length)) +
  geom_point() +
  theme_bw()

ggplot(iris, aes(x = Petal.Width, y = Petal.Length)) +
  geom_point() +
  theme_bw()


library(igraph)
empty_graph()

g <- make_empty_graph(n=23)
g <- add_edges(g, c(2,1,
                    3,2,
                    6,2,
                    5,2,
                    4,2,
                    7,3,
                    8,3,
                    8,9,
                    10,6,
                    11,10,
                    12,10,
                    14,10,
                    15,5,
                    13,10,
                    17,10,
                    18,15,
                    16,15,
                    19,2,
                    20,2,
                    21,2,
                    22,12,
                    23,22))

eg.id <- 6
breakpoints.v <- c(2,12)
breakpoints.h <- c(4,14,20)
deleted <- c(1,3,7,8,9,12,22,23,17,20,21)
V(g)$color <- 'white'
V(g)$color[eg.id] <- "grey"
V(g)[breakpoints.v]$color <- 'orange'
V(g)[breakpoints.h]$color <- 'yellow'
#V(g)[deleted]$color <- 'red'
par(mfrow=c(1,1))
g <- as.undirected(g)
la = layout_as_tree(g, mode='out', root=1)#which.min(V(g)$date))
V(g)$size <- 6

frame.colors <- rep("black",22)
frame.colors[deleted] <- "white"

plot(g,
     layout = la,
     vertex.label = order(V(g)),
     vertex.label = NA,
     edge.width = 1,
     edge.arrow.size=0.02,
     vertex.frame.color= frame.colors,
     vertex.label.color='black',
     asp=9/16,
     margin=-0.15)


#autor:      Joao Sollari Lopes
#local:      INE, Lisboa
#criado:     02.07.2017
#modificado: 02.07.2017

library("e1071")

trainset <- read.csv("../data/golf.csv",header=TRUE)
testset <- read.csv("../data/golf-testset.csv",header=TRUE)

mod <- naiveBayes(Play ~ Outlook + Wind,      #model design
                  trainset,                   #training set
                  laplace=0)                  #Laplace correction
res <- predict(mod,                           #model
               testset[,c("Outlook","Wind")]) #testing set

#Confusion Matrix
conf_mat <- table(testset[,c("Play")],res)
conf_mat

#Error rate
err_rt <- 100*(sum(conf_mat) - sum(diag(conf_mat)))/sum(conf_mat)
err_rt


# function that returns basic streak statistics given a sequence
streak_stats = function(results_sequence, streak_length){
  n_trials = length(results_sequence)
  n_success = sum(results_sequence)

  run_lengths = rle(results_sequence)$lengths
  if_run_success = rle(results_sequence)$values
  n_runs = length(run_lengths)

  # runs of successes
  longest_run_success = max(run_lengths*if_run_success)
  n_runs_success = sum(if_run_success)

  # successes after streaks of Successes
  run_lengths_adj = run_lengths - streak_length + 1
  run_values_adj_S =
    if_run_success *
    (!((if_run_success == 1) &
         (run_lengths < streak_length)))
  n_after_Sstreak = sum(run_lengths_adj * run_values_adj_S) -
    run_values_adj_S[length(run_values_adj_S)]
  n_success_after_Sstreak = sum((run_lengths - streak_length) * run_values_adj_S)

  # runs of failures
  longest_run_failure = max(run_lengths*(1-if_run_success))
  n_runs_failure = sum(1-if_run_success)

  # successes after streaks of Failures
  run_values_adj_F =
    (1-if_run_success) *
    (!((if_run_success == 0) &
         (run_lengths < streak_length)))
  n_after_Fstreak = sum(run_lengths_adj * run_values_adj_F) -
    run_values_adj_F[length(run_values_adj_F)]
  n_success_after_Fstreak = n_after_Fstreak -
    sum((run_lengths - streak_length) * run_values_adj_F)

  # Proportion of hits on trials after streaks
  phat_after_Sstreak = n_success_after_Sstreak / n_after_Sstreak

  # Difference in proportion of hits (trials after streaks - all other trials)
  phat_after_no_Sstreak = (n_success - n_success_after_Sstreak)/
    (n_trials - n_after_Sstreak)
  phat_Sstreak_vs_others = phat_after_Sstreak - phat_after_no_Sstreak

  # Difference in proportion of hits (trials after hit streaks - trials after miss streaks)
  phat_after_Fstreak = n_success_after_Fstreak / n_after_Fstreak
  phat_Sstreak_vs_Fstreak = phat_after_Sstreak - phat_after_Fstreak

  # Hit streak frequency - proportion of trials that occur after hit streaks
  Sstreak_frequency  = n_after_Sstreak / (n_trials - streak_length)

  # collect the streak stats for the results sequence
  return(data.frame(phat_after_Sstreak,
                    phat_Sstreak_vs_others,
                    phat_Sstreak_vs_Fstreak,
                    Sstreak_frequency,
                    longest_run_success,
                    n_runs
                    #                     n_runs_success,
                    #                     phat_after_Fstreak,
                    #                     n_runs_failure,
                    #                     longest_run_failure,
  ))
}


#!/usr/bin/env Rscript
#	i/o and processing for data digitized from Chamberlin 2019
#	Eric Barefoot
#	Oct 2019

#	load required packages

require(tidyverse)
require(here)
if (interactive()) {
    require(colorout)
}

# read in data

chamb_data = read_csv(file = here('data','raw_data','chamberlin_digitized.csv'))
chamb_greyscale = read_csv(file = here('data','raw_data','chamberlin_colorscale.csv'))

# # plot to demonstrate linearity of color mapping
# chamb_greyscale %>% ggplot(aes(x = greyscale, y = frac_input)) + geom_point() + geom_smooth(method = 'lm', se = FALSE)

color_model = lm(frac_input~greyscale, data = chamb_greyscale)

chamb_data = chamb_data %>% mutate(frac_input = predict(color_model, .))

# simple plot up of basic dataset.
# chamb_data %>%
# ggplot(., aes(x = frac_elems, y = frac_supply)) +
# geom_point(aes(color = frac_input, shape = model))

# it looks like ellen did runs each with a constant value of overbank sediment input, and varied some other boundary condition to vary preserved elements.

comp_coded = chamb_data %>% filter(model == 'comp_avulsions') %>% mutate(exp_set =
case_when(
  between(frac_input, 0.55, 0.6) ~ 'Ac',
  between(frac_input, 0.46, 0.53) ~ 'Bc',
  between(frac_input, 0.39, 0.45) ~ 'Cc',
  between(frac_input, 0.3, 0.35) ~ 'Dc',
  between(frac_input, 0.2, 0.25) ~ 'Ec'
))

rand_coded = chamb_data %>% filter(model == 'random_avulsions') %>% mutate(exp_set =
case_when(
  between(frac_input, 0.48, 0.53) ~ 'Ar',
  between(frac_input, 0.39, 0.45) ~ 'Br',
  between(frac_input, 0.32, 0.38) ~ 'Cr',
  between(frac_input, 0.25, 0.3) ~ 'Dr',
  between(frac_input, 0.1, 0.25) ~ 'Er'
))

# some plots to show this procedure and goals.
#
# comp_coded %>%
# ggplot(., aes(x = frac_input, y = frac_elems)) +
# geom_point(aes(color = exp_set))
#
# rand_coded %>%
# ggplot(., aes(x = frac_input, y = frac_elems)) +
# geom_point(aes(color = exp_set))
#
# comp_coded %>% filter(!is.na(exp_set)) %>%
# ggplot(., aes(x = frac_elems, y = frac_supply)) +
# geom_smooth(aes(color = exp_set), method = 'lm', se = FALSE) +
# geom_point(aes(color = exp_set))
#
# rand_coded %>% filter(!is.na(exp_set)) %>%
# ggplot(., aes(x = frac_elems, y = frac_supply)) +
# geom_smooth(aes(color = exp_set), method = 'lm', se = FALSE) +
# geom_point(aes(color = exp_set))

coded_data = bind_rows(comp_coded, rand_coded)
coded_data = coded_data %>% filter_all(all_vars(!is.na(.))) %>%
mutate(frac_elems = frac_elems / 100)

saveRDS(coded_data, file = here('data','derived_data', 'chamberlin_model_data.rds'))


evaluate_solution <- function(solution_vector, constraint, tol=1e-14){
    if(ncol(constraint$constr) != length(solution_vector)){
        stop("constraint length must match solution vector length.")
    }
    b_hat <- constraint$constr %*% solution_vector
    b <- constraint$rhs
    # we check if it is smaller than 1e-14 because if we set it to 0,
    # we expect cases where floating point precision does not match
    constraints_were_met <- (b_hat - b) <= tol
    rownames(b)[which(constraints_were_met==FALSE)]
    valid_for_all_tasks <- all(constraints_were_met)
    return(valid_for_all_tasks)
}

evaluate_solutions <- function(solution_per_row_df, constraint, ...){
    apply(solution_per_row_df,1, evaluate_solution, constraint, ...)
}

evaluate_constraint_solution_pairs <- function(constraint_solution_pairs, ...){
    lapply(constraint_solution_pairs, function(x){
        evaluate_solutions(x$har_solutions, x$constraint_object, ...)
    })
}

every_solution_is_ind_valid <- function(soln_df_list, constraints_list, tol=1e-4){

ress <- all(lapply(1:length(soln_df_list), function (i){
    return(
        all(evaluate_solutions(soln_df_list[[i]], constraints_list[[i]], tol=tol))
        )
    })%>%dcc)
return(ress)
}


setwd('c:/tmp/sniffs/')
# http://stackoverflow.com/a/18660042
# install.packages("Hmisc", dependencies=T)
library("Hmisc")

y = seq(200000)
sizes = c(10,60,200,600,1000,1400,1460)
sizs = c('s10','s60','s200','s600','s1000','s1400','s1460')
iters = c("00", "01", "02" ,"03", "04", "05", "06", "07", "08", "09")

# https://stat.ethz.ch/pipermail/r-help/2010-November/259237.html
results = list()

# pull and store the means of the data
for (s in sizes) {
  # http://stackoverflow.com/questions/12614953/how-to-create-a-numeric-vector-of-zero-length-in-r
  means = numeric()
  for (i in iters) {
    file = paste("out_",i,"-eth1_",s,".dump",sep='')
    data = read.table(file,head=T)
    print(paste('Size ',s,', iteration ',i,': ',mean(data$delta),sep=''))
    means = c(means,mean(data$delta))
  }
  results = c(results, list(means))
}
names(results) = sizs

means = numeric()
sds = numeric()
vars = numeric()
# calculate measures of central tendancy
for(z in sizs) {
  m = mean(results[[z]])
  v = var(results[[z]])
  s = sd(results[[z]])
  out = paste(m,v,s)
  print(out)
  means = c(means,m)
  sds = c(sds,s)
  vars = c(vars,v)
}
names(means) = sizs
d = data.frame(
  x = sizes,
  y = means,
  sd = sds
)

# Draw a graph, because.
plot(d$x, d$y, type='n')
with (
  data = d,
  expr = errbar(x, y, y+sd, y-sd, add=F, pch=1, cap=.015,xlab='Payload size (B)',ylab='Service Time (ns)')
)
title(main='Service time of OpenVSwitch in VM')

# Cleaning the data
# find the values greater than upper quartile
dss = numeric()

for (i in seq(200000)) {
  if (data$delta[i]>x){
    dss=c(dss,data$delta[i]);
    count=count+1
  }
}
# look dss
quantiles(dss)
#decide a point to cut off
x = 61790.25
d = data$delta

for (i in seq(200000)) {
  if (data$delta[i]>x){
     d[i] = NA
  }
}
# Finding lower bound on data
plot(plot(y,d,xlab='samples',ylab='service time (ns)',main="Service times, 600B, 5th iteration",pch='.')
abline(h=15500)

# remove it
for (i in seq(200000)) {
  if (data$delta[i]>15500){
    d[i] = NA
  }
}

# plot, and then mean(d,na.rm=T)
plot(plot(y,d,xlab='samples',ylab='service time (ns)',main="Service times, 600B, 5th iteration",pch='.')
hist(d,breaks=100,xlab='Service time (ns)',main="Service times, 600B, 5th iteration"))


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

iris <- read.csv("../../../data/iris.csv", fileEncoding='UTF-8-BOM')
iris_class <- as.data.frame(table(iris$Class))
names(iris_class) <- c('label', 'count')

# Create Pie Chart
pie <- ggplot(iris_class,
            aes(x = "",
            y = count,
            fill = label)) +
            geom_bar(stat='identity') +     # First create a stacked bar plot; stat='identity' is a must
            coord_polar("y")                # Then turn the plot into a circle by axis y

# Anotate the share Ratio
count <- iris_class$count
share <- count / sum(count) * 100
for(i in 1:nrow(iris_class)){
    pie <- pie + annotate("text",
                        x = 1,                                  # x is now the distance from the original point
                        y = cumsum(count)[i]-0.5*count[i],      # y is now the angle coordinate
                        label = sprintf("%.2f%%", share[i]),
                        colour = "white",
                        fontface= "bold")
}

# Set labels
pie <- pie +
    labs(fill = "Class if Iris") +  # Rename the legend label
    labs(x = NULL) +                # Remove x-axis label
    labs(y = NULL)                  # Remove y-axis label

# Set Title
pie <- pie +
    ggtitle("Number of Samples for Each Iris Class in the Dataset") +
    theme(plot.title = element_text(face="bold", hjust=0.5))

# Show the Figure
pie

EDA Examining Distributions/One Categorical Variable/r/ggplot2_pie_chart_example.r


proprietary <- "agent,desc,count
buy,Assists in buying goods.,480
service,Do It Yourself type tasks,284
self-improve,Self Improvement/Help,183
school-work,Task related to school,158
contact,Email SMS or call,101
call,Makes a phone call via OS,97
email,Emails a contact via OS,60
calendar,Make an appointment,55
pay-bill-online,Online bill pay,54
find-service,Procure services,42
print,Print out a document,23
postal,Send mail by snail mail,20
plan-meal,Cook or gather ingredients,17
find-travel,Reserve transportation,18
text-sms,Sends SMS text messages,19"

public <- "agent,desc,count
buy-general,Assists in buying general goods,38
buy-grocery,Assists in buying groceries,2
buy-travel,Assists in buying travel,9
buy-wedding,Assists in buying wedding g/s,44
calendar,Make personal appointment,33
contact,Email SMS or phone call,66
household,Schedule time for personal task in calendar,91
how-to,Identify tutorial video,17
office,Schedule office task in calendar,189
office-calendar,Make work appt,8
office-contact,Email SMS or phone call - work,19
pay-bill-online,Online bill pay,18
search-general,General internet search,17
search-recipe,Internet search recipe,4
sell,Sell or donate an item,7
send,Send item by USPS,15"

corp.dist <- function(csvstr, name) {
    df = read.csv(text=csvstr, header=TRUE)
    counts <- df[,3]
    print(sprintf('%s:', name))
    summary(counts)
    print(sprintf('standard deviation: %.2f, varience: %.2f', sd(counts), var(counts)))
}

corp.dist(proprietary, 'proprietary')
corp.dist(public, 'public')


base::source('api.r')

api <- API()

data <- load(0.5, shuffle=TRUE)

api$dimensionality_reduction(data$X_train, data$y_train)
result_gam <- api$gam(data$X_train, data$y_train, data$X_test, data$y_test, drm='pca', number=5)
print(r2_score(result_gam$y_true, result_gam$y_pred))

result_splines <- api$splines(data$X_train, data$y_train, data$X_test, data$y_test, drm='mic', number=5)
print(mean_squared_error(result_splines$y_true, result_splines$y_pred))


## 2. Exploring the Airbnb dataset ##

library(readr)
dc_listings <- read.csv('dc_airbnb.csv')
colnames(dc_listings)
has_missing <- TRUE

## 3. The k-nearest neighbors algorithm ##

predicted_rent <- mean(c(476, 750, 1128))

## 4. A numerical description for similarity ##

dc_listings <- read.csv('dc_airbnb.csv')
first_row_acc_value <- dc_listings$accommodates[1]
our_acc_value <- 3

first_distance <- abs(our_acc_value - first_row_acc_value)

## 5. Calculate distance for all observations ##

dc_listings <- read.csv('dc_airbnb.csv')
our_acc_value <- 3
dc_listings <- dc_listings %>%
  mutate(
    distance = abs(accommodates - our_acc_value)
  )

## 6. Using randomization ##

dc_listings <- dc_listings %>%
  mutate(
    distance = abs(accommodates - our_acc_value)
  )
zero_distance_indices <- which(dc_listings$distance == 0)
random_three_indices <- sample(zero_distance_indices, 3, replace = FALSE)

## 7. Cleaning the `price` column ##

dc_listings <- dc_listings %>%
  mutate(
    distance = abs(accommodates - our_acc_value)
  )
zero_distance_indices <- which(dc_listings$distance == 0)
random_three_indices <- sample(zero_distance_indices, 3, replace = FALSE)
dc_listings <- dc_listings %>%
  mutate(
    price = as.character(price),
    tidy_price = str_replace_all(price, "\\$", ""),
    tidy_price = str_replace_all(tidy_price, ",", ""),
    tidy_price = as.numeric(tidy_price)
  )

## 8. Calculating average price ##

dc_listings <- dc_listings %>%
  mutate(
    distance = abs(accommodates - our_acc_value)
  )
zero_distance_indices <- which(dc_listings$distance == 0)
random_three_indices <- sample(zero_distance_indices, 3, replace = FALSE)

dc_listings <- dc_listings %>%
  mutate(
    price = as.character(price),
    tidy_price = str_replace_all(price, "\\$", ""),
    tidy_price = str_replace_all(tidy_price, ",", ""),
    tidy_price = as.numeric(tidy_price)
  )
mean_price <- mean(dc_listings$tidy_price[random_three_indices])

Data Analyst in R/Step 6 - Predictive Modeling and Machine Learning in R/2. Machine Learning Fundamentals in R/1. Introduction to Machine Learning Concepts.r


# Pre-load all R packages
suppressPackageStartupMessages(library(data.table))
suppressPackageStartupMessages(library(h2o))
suppressPackageStartupMessages(library(plotly))

# Start and connect to a H2O cluster (JVM)
h2o.init(nthreads = -1)

# Import pre-processed datasets

# locally (if you have the datasets in the 'data' sub-folder)
# hex_train <- h2o.importFile("./data/train.csv.gz")
# hex_test <- h2o.importFile("./data/test.csv.gz")

# or directly from the web (github)
hex_train <- h2o.importFile("https://github.com/woobe/h2o_demos/blob/master/human_activitiy_recognition_with_smartphones/data/train.csv.gz?raw=true")
hex_test <- h2o.importFile("https://github.com/woobe/h2o_demos/blob/master/human_activitiy_recognition_with_smartphones/data/test.csv.gz?raw=true")

# Dimensions
# 'Train' dataset has 7352 rows and 562 columns
# 'Test' dataset has 2947 rows and 562 columns
dim(hex_train)
dim(hex_test)

# First few records
# First column is the label 'activity'
# Rest of the columns (V1 to V561) are sensors data
head(hex_train)
head(hex_test)

# Look at 'activity' column
# Six classes (Carinality = 6)
# No missing value
h2o.describe(hex_train$activity)
h2o.describe(hex_test$activity)

# Extract 'activity' columns for other graphics packages in R
d_activity_train <- as.data.frame(hex_train$activity)
d_activity_test <- as.data.frame(hex_test$activity)

# Count acitivity
d_freq_train <- as.data.frame(table(d_activity_train))
d_freq_test <- as.data.frame(table(d_activity_test))
d_freq <- merge(d_freq_train, d_freq_test, by.x = "d_activity_train", by.y = "d_activity_test", sort = FALSE)
colnames(d_freq) <- c("activity", "freq_train", "freq_test")
d_freq

# Visualize 'activity' in both 'train' and 'test'
p <- plot_ly(d_freq, x = ~activity, y = ~freq_train, type = 'bar', name = 'Frequency (Train)') %>%
  add_trace(y = ~freq_test, name = 'Frequency (Test)') %>%
  layout(title = "Activities in 'Train' and 'Test' Dataset") %>%
  layout(yaxis = list(title = 'Count'), xaxis = list(title = "")) %>%
  layout(margin = list(b = 90)) %>%
  layout(barmode = "group")
p

# Look at relationship between sensor data V1 and activity
d_v1 <- data.frame(V1_train = as.data.frame(hex_train$V1), activity = as.data.frame(hex_train$activity))
head(d_v1)

p <- plot_ly(d_v1, y = ~V1, color = ~activity, type = "box") %>%
     layout(title = "Relationship between Sensor Data V1 and Activities") %>%
     layout(yaxis = list(title = 'Sensor Data V1'), xaxis = list(title = "")) %>%
     layout(margin = list(b = 90))
p

# Principal Component Analysis
# 95% of variance in original data captured by first five principal components
suppressWarnings(
    model_pca <- h2o.prcomp(training_frame = hex_train,
                        x = 2:562,
                        model_id = "h2o_pca",
                        k = 5)
)
model_pca

# Visualize principle components with activity labels
d_pca <- as.data.frame(h2o.predict(model_pca, hex_train))
d_pca <- data.frame(d_pca, as.data.frame(hex_train$activity))
head(d_pca)

p <- plot_ly(data = d_pca, x = ~PC2, y = ~PC3, color = ~activity,
             type = "scatter", mode = "markers", marker = list(size = 3)) %>%
     layout(title = "Visualizing Principle Components")
p

# Define target and features for model training
target <- "activity"
features <- setdiff(colnames(hex_train), target) # i.e. using the records of all 561 sensors

# Build a GBM model
model <- h2o.gbm(x = features,
                 y = target,
                 training_frame = hex_train,
                 model_id = "h2o_gbm",
                 ntrees = 500,
                 learn_rate = 0.05,
                 learn_rate_annealing = 0.999,
                 max_depth = 7,
                 sample_rate = 0.9,
                 col_sample_rate = 0.9,
                 nfolds = 3,
                 fold_assignment = "Stratified",
                 stopping_metric = "logloss",
                 stopping_rounds = 5,
                 score_tree_interval = 10,
                 seed = 1234)

# Print out model summary
model

# Make predictions
yhat_test <- h2o.predict(model, hex_test)
head(yhat_test)

# Evaluate predictions
h2o.performance(model, newdata = hex_test)

# Not Run
# Showing the syntax for now
# h2o.saveMojo(model, path = "")


library("ggpubr")
library(tidyverse)

AdolescentM <- read.csv("C:/Users/amira/Downloads/AdolescentM.csv")
AdultM <- read.csv("C:/Users/amira/Downloads/AdultM.csv")

t.test(AdolescentM$DecisionTime, AdultM$DecisionTime)


### fimd7.R
### R code from Van Buuren, S. (2012).
###		Flexible Imputation of Missing Data.
###		CRC/Chapman & Hall, Boca Raton, FL.
### (c) 2012 Stef van Buuren, www.multiple-imputation.com
### Version 1, 22mar2012
### Version 2, 4nov2015 tested with mice 2.23
### Tested with Mac OS X 10.7.3, R2.14-2, mice 2.12

if (packageVersion("mice")<'2.12') stop("This code requires mice 2.12.")

### Section 7.1 Too many columns

library("mice")
library("lattice")
library("foreign")
library("survival")

### Section 7.1.3 Data exploration

data <- leiden85   ## Note: the leiden85 data is not yet avialable in V2.12
if (!is.data.frame(data)) warning("The code for section 7.1/7.2 requires access to the LEIDEN85 data.")

ini <- mice(data, maxit=0)   # recommended
table(ini$nmis)

table(data$beroep1, useNA="always")

v1 <- names(ini$nmis[ini$nmis==0])
outlist1 <- v1[c(1,3:5,7:10,16:47,51:60,62,64:65,69:72)]
length(outlist1)

### Section 7.1.4 Outflux

fx <- fluxplot(data, main=NULL, cex=0.9)

outlist2 <- row.names(fx)[fx$outflux<0.5]
length(outlist2)

data2 <- data[,!names(data) %in% outlist2]
fx2 <- flux(data2)
outlist3 <- row.names(fx2)[fx2$outflux<0.5]

### Section 7.1.5 Logged events

ini$log[1:3,]

outlist4 <- as.character(ini$log[,"out"])

### Section 7.1.6 Quick predictor selection for wide data

outlist <- unique(c(outlist1, outlist2, outlist4))
length(outlist)

data2 <- data[,!names(data) %in% outlist]

inlist <- c("sex","lftanam","rrsyst","rrdiast")
pred <- quickpred(data2, minpuc=0.5, inc=inlist)

table(rowSums(pred))

rowSums(pred[c("rrsyst","rrdiast"),])

names(data2)[pred["rrsyst",]==1]

vname <- "rrsyst"
y <- cbind(data2[vname], r=!is.na(data2[,vname]))
vdata <- data2[,pred[vname,]==1]
round(cor(y=y,x=vdata,use="pair"),2)

### Section 7.1.7 Generating the imputations

### Smart imputation using quickpred - - TIME COMSUMING (30 MINUTES)
imp.qp <- mice(data2, pred=pred, ridge = 0.0001, seed=29725)

### Blind imputation - MUCH MORE TIME CONSUMING (10 HOURS)
### Not recommended
imp <- mice(data, ridge=0.01, seed=32417, maxit=2)

vnames <- c("rrsyst","rrdiast")
cd1 <- complete(imp)[,vnames]
cd2 <- complete(imp.qp)[,vnames]
typ <- factor(rep(c("blind imputation","quickpred"),each=nrow(cd1)))
mis <- ici(data2[,vnames])
mis <- is.na(imp$data$rrsyst)|is.na(imp$data$rrdiast)
cd <- data.frame(typ=typ,mis=mis,rbind(cd1, cd2))
tp72 <- xyplot(jitter(rrdiast,10) ~ jitter(rrsyst,10) | typ, data = cd, groups = mis,
             xlab = "Systolic BP (mmHg)", ylab = "Diastolic BP (mmHg)",
             col=c(mdc(1),mdc(2)), pch=c(1,19),type=c("g","p"),
             strip = strip.custom(bg="grey95"),
             scales = list(alternating=1, tck=c(1,0)))
print(tp72)

### Section 7.1.8 A further improvements: Survival as predictor variable

dat <- cbind(data2, dead = 1 - data2$dwa)
hazard <- nelsonaalen(dat, survda, dead)

### calculate correlations between hazard, t and logt (not in
tmp <- data.frame(hazard, t=data2$survda, logt=log(data2$survda),
                  SBP=data2$rrsyst, DBP=data2$rrdiast)
round(cor(tmp, use="pair"),3)

### Section 7.2 Sensitivity analysis

### Figure 7.3

fit <- survfit(Surv(survda/365, 1-dwa) ~ is.na(rrsyst), data = data2)
plot(fit, lty = 1, lwd=1.5, xlab="Years since intake",
     ylab="K-M Survival probability", las=1,
     col=c(mdc(4),mdc(5)), mark.time=FALSE)
text(4,0.7,"BP measured")
text(2,0.3,"BP missing")

### Section 7.2.3 Generating imputations under the delta-adjustment
delta <- c(0,-5,-10,-15,-20)
post <- imp.qp$post

### undamped sensitivity analysis
### TIME CONSUMING (SEVERAL HOURS)
imp.all.undamped <- vector("list", length(delta))
for (i in 1:length(delta)) {
  d <- delta[i]
  cmd <- paste("imp[[j]][,i] <- imp[[j]][,i] +",d)
  post["rrsyst"] <- cmd
  imp <- mice(data2, pred=pred, post=post, maxit=1, seed=i*22, ridge=0.0001)
  imp.all.undamped[[i]] <- imp
}

### damped sensitivity analysis
### TIME CONSUMING (SEVERAL HOURS)
imp.all.damped <- vector("list", length(delta))
for (i in 1:length(delta)) {
  d <- delta[i]
  cmd <- paste("fit <- lm(y ~ as.matrix(x));
              damp <- sqrt(1 - summary(fit)$r.squared);
              imp[[j]][, i] <- imp[[j]][, i] + damp * ", d)
  post["rrsyst"] <- cmd
  imp <- mice(data2, pred=pred, post=post, maxit=1, seed=i*22, ridge=0.0001)
  imp.all.damped[[i]] <- imp
}

### Section 7.2.4 Complete data analysis

cda <- expression(
    sbpgp <- cut(rrsyst, breaks = c(50, 124,
          144, 164, 184, 200, 500)),
    agegp <- cut(lftanam, breaks = c(85, 90,
          95, 110)),
    dead  <- 1 - dwa,
    coxph(Surv(survda, dead)
          ~ C(sbpgp, contr.treatment(6, base = 3))
          + strata(sexe, agegp)))
imp <- imp.all.damped[[1]]
fit <- with(imp, cda)
as.vector(exp(summary(pool(fit))[,1]))

### Table 7.5

fit1 <- with(imp.all.damped[[1]], cda)
fit2 <- with(imp.all.damped[[2]], cda)
fit3 <- with(imp.all.damped[[3]], cda)
fit4 <- with(imp.all.damped[[4]], cda)
fit5 <- with(imp.all.damped[[5]], cda)
r1<-as.vector(t(exp(summary(pool(fit1))[,c(1,6:7)])))
r2<-as.vector(t(exp(summary(pool(fit2))[,c(1,6:7)])))
r3<-as.vector(t(exp(summary(pool(fit3))[,c(1,6:7)])))
r4<-as.vector(t(exp(summary(pool(fit4))[,c(1,6:7)])))
r5<-as.vector(t(exp(summary(pool(fit5))[,c(1,6:7)])))
round(t(matrix(c(r1,r2,r3,r4,r5),nrow=15)),2)

### Section 7.3 Correct prevalence estimates from self-reported data

library("mice")
krul <- selfreport[selfreport$src=="krul",]
mgg <- selfreport[selfreport$src=="mgg",]

### Figure 7.4

xy <- xy.coords(krul$bm, krul$br-krul$bm)
plot(xy,col=mdc(1),xlab="Measured BMI",ylab="Reported - Measured BMI",
     xlim=c(17,45),ylim=c(-5,5), type="n",lwd=0.7)
polygon(x=c(30,20,30),y=c(0,10,10),col="grey95",border=NA)
polygon(x=c(30,40,30),y=c(0,-10,-10),col="grey95",border=NA)
abline(0,0,lty=2,lwd=0.7)
points(xy, col=mdc(1),cex=0.7)
lines(lowess(xy),lwd=2,col=mdc(4))
text(1:4,x=c(40,28,20,32),y=c(4,4,-4,-4),cex=3)
box(lwd=1)

### Figure 7.5 Krul data - males
males <- krul[krul$sex=="Male",]
fit <- lm(bm~br,data=males)
plot(x=males$br,y=males$bm,
     xlim=c(26,34),ylim=c(26,34),
     xlab="Self-reported BMI",ylab="Measured BMI",col=mdc(1),
     cex.lab=1.5, cex.axis=1.3)
abline(h=30,v=30,lty=2)
abline(coef(fit),col=mdc(4))
abline(v=(30-coef(fit)[1])/coef(fit)[2],col=mdc(4))
text(1:4,x=c(33.8,33.8,26.2,26.2),y=c(33.8,26.2,26.2,33.8),cex=4)
text(c("a","b"),x=c(29.1,29.7,29.1,29.7),y=c(34.1,34.1,26.4,26.4),cex=3,adj=c(0.5,1))

### Section 7.3.4 Data

md.pattern(selfreport[,c("age","sex","hm","hr","wm","wr")])

### Section 7.3.5 Application

bmi <- function(h,w){return(w/(h/100)^2)}
init <- mice(selfreport,maxit=0)
meth <- init$meth
meth["bm"] <- "~bmi(hm,wm)"
meth[c("prg", "edu", "etn")] <- ""
pred <- init$pred
pred[,c("src","id","pop","prg","edu","etn","web","bm","br")] <- 0
imp <- mice(selfreport, pred=pred, meth=meth, seed=66573, maxit=20, m=10)

### Figure 7.6

cd <- complete(imp, 1)
xy <- xy.coords(cd$bm, cd$br-cd$bm)
plot(xy,col=mdc(2),xlab="Measured BMI",ylab="Reported - Measured BMI",
     xlim=c(17,45),ylim=c(-5,5), type="n",lwd=0.7)
polygon(x=c(30,20,30),y=c(0,10,10),col="grey95",border=NA)
polygon(x=c(30,40,30),y=c(0,-10,-10),col="grey95",border=NA)
abline(0,0,lty=2,lwd=0.7)

idx <- cd$src=="krul"
xyc <- xy; xyc$x <- xy$x[idx]; xyc$y <- xy$y[idx]
xys <- xy; xys$x <- xy$x[!idx]; xys$y <- xy$y[!idx]
points(xyc,col=mdc(1), cex=0.7)
points(xys,col=mdc(2), cex=0.7)
lines(lowess(xyc),col=mdc(4),lwd=2)
lines(lowess(xys),col=mdc(5),lwd=2)
text(1:4,x=c(40,28,20,32),y=c(4,4,-4,-4),cex=3)
box(lwd=1)

### Table 7.7
### Not particularly elegant code, at the moment
  prev <- matrix(NA,nr=15,nc=4)
  prev[1,1:2] <- summary(pool(with(imp, lm(br>=30~1,subset=(src=="mgg")))))[1,1:2]
  prev[1,3:4] <- summary(pool(with(imp, lm(bm>=30~1,subset=(src=="mgg")))))[1,1:2]
  prev[2,1:2] <- summary(pool(with(imp, lm(br>=30~1,subset=(src=="mgg"&sex=="Male")))))[1,1:2]
  prev[2,3:4] <- summary(pool(with(imp, lm(bm>=30~1,subset=(src=="mgg"&sex=="Male")))))[1,1:2]
  prev[3,1:2] <- summary(pool(with(imp, lm(br>=30~1,subset=(src=="mgg"&sex=="Female")))))[1,1:2]
  prev[3,3:4] <- summary(pool(with(imp, lm(bm>=30~1,subset=(src=="mgg"&sex=="Female")))))[1,1:2]
  prev[4,1:2] <- summary(pool(with(imp, lm(br>=30~1,subset=(src=="mgg"&sex=="Male"&age>=18&age<30)))))[1,1:2]
  prev[4,3:4] <- summary(pool(with(imp, lm(bm>=30~1,subset=(src=="mgg"&sex=="Male"&age>18&age<30)))))[1,1:2]
  prev[5,1:2] <- summary(pool(with(imp, lm(br>=30~1,subset=(src=="mgg"&sex=="Male"&age>=30&age<40)))))[1,1:2]
  prev[5,3:4] <- summary(pool(with(imp, lm(bm>=30~1,subset=(src=="mgg"&sex=="Male"&age>30&age<40)))))[1,1:2]
  prev[6,1:2] <- summary(pool(with(imp, lm(br>=30~1,subset=(src=="mgg"&sex=="Male"&age>=40&age<50)))))[1,1:2]
  prev[6,3:4] <- summary(pool(with(imp, lm(bm>=30~1,subset=(src=="mgg"&sex=="Male"&age>40&age<50)))))[1,1:2]
  prev[7,1:2] <- summary(pool(with(imp, lm(br>=30~1,subset=(src=="mgg"&sex=="Male"&age>=50&age<60)))))[1,1:2]
  prev[7,3:4] <- summary(pool(with(imp, lm(bm>=30~1,subset=(src=="mgg"&sex=="Male"&age>50&age<60)))))[1,1:2]
  prev[8,1:2] <- summary(pool(with(imp, lm(br>=30~1,subset=(src=="mgg"&sex=="Male"&age>=60&age<80)))))[1,1:2]
  prev[8,3:4] <- summary(pool(with(imp, lm(bm>=30~1,subset=(src=="mgg"&sex=="Male"&age>60&age<80)))))[1,1:2]
  prev[10,1:2] <- summary(pool(with(imp, lm(br>=30~1,subset=(src=="mgg"&sex=="Female"&age>=18&age<30)))))[1,1:2]
  prev[10,3:4] <- summary(pool(with(imp, lm(bm>=30~1,subset=(src=="mgg"&sex=="Female"&age>18&age<30)))))[1,1:2]
  prev[11,1:2] <- summary(pool(with(imp, lm(br>=30~1,subset=(src=="mgg"&sex=="Female"&age>=30&age<40)))))[1,1:2]
  prev[11,3:4] <- summary(pool(with(imp, lm(bm>=30~1,subset=(src=="mgg"&sex=="Female"&age>30&age<40)))))[1,1:2]
  prev[12,1:2] <- summary(pool(with(imp, lm(br>=30~1,subset=(src=="mgg"&sex=="Female"&age>=40&age<50)))))[1,1:2]
  prev[12,3:4] <- summary(pool(with(imp, lm(bm>=30~1,subset=(src=="mgg"&sex=="Female"&age>40&age<50)))))[1,1:2]
  prev[13,1:2] <- summary(pool(with(imp, lm(br>=30~1,subset=(src=="mgg"&sex=="Female"&age>=50&age<60)))))[1,1:2]
  prev[13,3:4] <- summary(pool(with(imp, lm(bm>=30~1,subset=(src=="mgg"&sex=="Female"&age>50&age<60)))))[1,1:2]
  prev[14,1:2] <- summary(pool(with(imp, lm(br>=30~1,subset=(src=="mgg"&sex=="Female"&age>=60&age<80)))))[1,1:2]
  prev[14,3:4] <- summary(pool(with(imp, lm(bm>=30~1,subset=(src=="mgg"&sex=="Female"&age>60&age<80)))))[1,1:2]

### find group sizes
table(mgg$sex,mgg$web)
table(mgg$sex,mgg$web,mgg$age>55)

### Section 7.4 Enhancing comparability

library("mice")

### Section 7.4.3 Independence: Imputation without a bridge study

fA <- c(242, 43, 15, 0, 6)
fB <- c(145, 110, 29, 8)
YA <- rep(ordered(c(0:3,NA)), fA)
YB <- rep(ordered(c(0:3)), fB)
Y <- rbind(data.frame(YA,YB=ordered(NA)),
           data.frame(YB,YA=ordered(NA)))

md.pattern(Y)

### simulation function
### Warning: micemill() overwrites objects 'imp' and 'tau'
###          in the global enviroment

micemill <- function(n) {
  for (i in 1:n) {
    imp <<- mice.mids(imp) # global assignment
    cors <- with(imp, cor(as.numeric(YA),
                         as.numeric(YB),
                         method="kendall"))
    tau <<- rbind(tau, getfit(cors, s=TRUE))  # global assignment
  }
}

tau <- NULL
imp <- mice(Y, max=0, m=10, seed=32662)
micemill(50)

### Figure 7.7
plotit <- function()
  matplot(x=1:nrow(tau),y=tau,
        ylab=expression(paste("Kendall's ",tau)),
          xlab="Iteration", type="l", lwd=1,
        lty=1:10,col="black")
plotit()

### Section 7.4.4 Fully dependent or independent?
### Use the 'walking' dataset of the mice package

## split walking: ab is sources A and B (598 records)
ab <- walking[walking$src=="A"|walking$src=="B",]

## split walking: euridiss is external source (292 records)
external <- walking[walking$src=="E",]

### create contingency tables: YA by YB (in ab)
ftable(addmargins(table(ab[,c("YA","YB")],useNA="ifany")))

### Table 7.8 contingency table YA by YB (in euridiss)
ftable(addmargins(table(external[,c("YA","YB")],useNA="ifany")))

### Section 7.4.5 Imputation using a bridge study
md.pattern(walking)

### Figure 7.8
tau <- NULL
imp <- mice(walking, max=0, m=10, seed=92786)
pred <- imp$pred
pred[,c("src","age","sex")] <- 0
imp <- mice(walking, max=0, m=10, seed=92786, pred=pred)
micemill(20)
plotit()

### impute without and with covariates

thetaAB <- NULL
props <- with(imp, mean(YB[src=="A"]=='0'))
thetaAB <<- rbind(thetaAB, getfit(props, s=TRUE))

micemill <- function(n) {
  for (i in 1:n) {
    imp <<- mice.mids(imp) # global assignment
    cors <- with(imp, cor(as.numeric(YA[src=="A"]),
                         as.numeric(YB[src=="A"]),
                         method="kendall"))
    tau <<- rbind(tau, getfit(cors, s=TRUE))  # global assignment
    means <- with(imp, mean(as.numeric(YA[src=="A"]), na.rm=TRUE))
    thetaBA <<- rbind(thetaBA, getfit(means, s=TRUE)-1)
    props <- with(imp, mean(YB[src=="A"]=='0'))
    thetaAB <<- rbind(thetaAB, getfit(props, s=TRUE))
    tabs <- with(imp, ftable(addmargins(
                      table(YA[src=="A"],YB[src=="A"],
                            useNA="ifany", dnn=c("YA","YB")))))
    print(getfit(tabs)[[2]])
  }
}

tau <- NULL
thetaBA <- NULL
thetaAB <- NULL
imp <- mice(walking, max=0, m=10, seed=99786)
oldpred <- pred <- imp$pred
pred[,c("src","age","sex")] <- 0
imp <- mice(walking, max=0, m=10, seed=99786, pred=pred)
micemill(20)
pred <- oldpred
pred[,c("src")] <- 0
imp <- mice(walking, max=0, m=10, pred=pred)
micemill(20)

### Figure 7.9

matplot(x=1:nrow(thetaAB),y=thetaAB,xlab="Iteration",
        ylab = expression(hat(theta)[AB]),
        type="l", lwd=1, lty=1:10,col="black",
        ylim=c(0.4,0.7))
abline(h=0.497, v=20, lty=2)
text(x=5,y=0.488,expression(hat(theta)[BB]),adj=0)
text(x=5,y=0.430,"Without covariates", adj=0)
text(x=25,y=0.430,"With covariates", adj=0)
arrows(x0=4.5,y0=0.488,x1=0,y1=0.495,length=0.1, angle=20)
points(x=-0.4,y=0.497,pch=20)

## file <- file.path("~/Documents/Sync/Impute/mice/V2.12/mice/data/walking.rda")
## save(walking, file=file)

## selfreport <- nl
## file <- file.path("~/Documents/Sync/Impute/mice/V2.12/mice/data/selfreport.rda")
## save(selfreport, file=file)


library(zoo)
# hosp døde forventet -----------------------------------------------------

plot_data <- read_csv2("../data/SSI_plot_data.csv")

p1 <- plot_data %>%
  filter(name %in% c("Positive", "Deaths", "Admitted", "Tested")) %>%
  pivot_wider(names_from = name, values_from = c(daily, ra), names_sep = "_") %>%
  rename(
    obs_death_y = ra_Deaths,
    obs_admit_y= ra_Admitted
  ) %>%
  mutate(
    pool_30 = rollsum(daily_Positive, 30, align = "right", na.pad = TRUE),
    pool_14 = rollsum(daily_Positive, 14, align = "right", na.pad = TRUE),
    pred_death_y =  pool_30 * 150 / 5800000,
    pred_admit_lo = (pool_14 * 2500 / 5800000) + (2500 * ra(daily_Positive / daily_Tested) * 0.75),
    pred_admit_hi = (pool_14 * 3500 / 5800000) + (3000 * ra(daily_Positive / daily_Tested) * 1.25)
    ) %>%
  select(Date, obs_death_y, obs_admit_y, pred_death_y, pred_admit_lo, pred_admit_hi) %>%
  pivot_longer(-Date, names_to = c("type", "variable", "limit"), names_sep = "_") %>%
  pivot_wider(names_from = limit, values_from = value) %>%
  filter(Date >= ymd("2021-02-01")) %>%
  ggplot() +
  geom_line(aes(Date, y, color = type), size = 1)+#, alpha = type, size = type)) +
  geom_ribbon(aes(Date, ymin = lo, ymax = hi, fill = type), alpha = 0.8) +
  facet_wrap(~ variable, scales = "free", labeller = as_labeller(c("death" = "Døde",  "admit" = "Nyindlæggelser"))) +
  scale_alpha_manual(
    name = "",
    labels = c("Observeret", "Forventet"),
    values = c(0.7, 1)
  ) +
  scale_size_manual(
    name = "",
    labels = c("Observeret", "Forventet"),
    values = c(0.4, 1)
  ) +
  scale_x_date(labels = my_date_labels, breaks = "1 months", minor_break = "1 month") +
  scale_y_continuous(limits = c(0, NA)) +
  labs(
    x = "Dato",
    y = "Antal",
    title = "Nedre grænse for antal COVID-19 nyindlæggelser og døde

Fordi antallet af COVID-19 indlæggelser og døde kun er baseret på en positiv SARS-CoV-2 test, kan der registreres nyindlagte og døde selv i et scenarie hvor ingen indlægges eller dør pga. COVID-19.

De nedre grænser er beregnet udfra antal PCR positive, den gennemsnitlige statistiske risiko for hhv. indlæggelse og død, og metoden hvormed COVID-19 indlæggelser og døde opgøres.

Estimeret nedre grænse for indlagte viser et interval mellem et muligt lavt og højt scenarie
",
    caption = "Kristoffer T. Bæk, covid19danmark.dk, datakilde: SSI") +
  scale_colour_brewer(palette = "Set2", name = "",
                      labels = c("Observeret 7-dages gennemsnit", "Estimeret nedre grænse")) +
  scale_fill_brewer(palette = "Set2", name = "",
                      labels = c("Observeret 7-dages gennemsnit", "Estimeret nedre grænse")) +
  facet_theme +
  theme(
    plot.margin = margin(.6, .6, .3, .6, "cm"),
    plot.title.position = "plot",
    plot.title = element_textbox_simple(
      size = 9, face = "plain", lineheight = 1.1, padding = margin(0, 5, 5, 0)
    ),
  strip.text = element_text(size = 10, face = "bold")
  )

ggsave("../figures/ntl_admit_death_expected.png", width = 20, height = 11, units = "cm", dpi = 300)

vaxx <- done_vax_df %>%
  pivot_longer(-Date) %>%
  replace_na(list(value = 0)) %>%
  mutate(cum_value = cumsum(value)) %>%
  mutate(cum_value = ifelse(cum_value == 0, NA, cum_value)) %>%
  mutate(unvaxx_prop = (5800000 - cum_value) / 5800000) %>%
  select(Date, unvaxx_prop)

plot_data %>%
  filter(name %in% c("Positive", "Admitted", "Tested")) %>%
  pivot_wider(names_from = name, values_from = c(daily, ra), names_sep = "_") %>%
  full_join(vaxx, by = "Date") %>%
  rename(
    obs_admit_y= ra_Admitted
  ) %>%
  mutate(
    pool_14 = rollsum(daily_Positive, 14, align = "right", na.pad = TRUE),
    pred_admit_lo = (pool_14 * 2500 / 5800000) + (2500 * unvaxx_prop * ra(daily_Positive / daily_Tested) * 0.7),
    pred_admit_hi = (pool_14 * 2500 / 5800000) + (2500 * unvaxx_prop * ra(daily_Positive / daily_Tested) * 1.5)
  ) %>%
  select(Date, obs_admit_y, pred_admit_lo, pred_admit_hi) %>%
  pivot_longer(-Date, names_to = c("type", "variable", "limit"), names_sep = "_") %>%
  pivot_wider(names_from = limit, values_from = value) %>%
  filter(Date >= ymd("2021-02-01")) %>%
  ggplot() +
  geom_ribbon(aes(Date, ymin = lo, ymax = hi, fill = type), alpha = 0.8) +
  geom_line(aes(Date, y, color = type), size = 1)+#, alpha = type, size = type)) +
  scale_x_date(labels = my_date_labels, breaks = "1 months", minor_break = "1 month") +
  scale_y_continuous(limits = c(0, NA)) +
  labs(
    x = "Dato",
    y = "Antal",
    title = "Nedre grænse for antal COVID-19 nyindlæggelser

Fordi antallet af COVID-19 indlæggelser kun er baseret på en positiv SARS-CoV-2 test, kan der registreres nyindlagte selv i et scenarie hvor ingen indlægges pga. COVID-19.

Den nedre grænse er beregnet udfra antal PCR positive, den gennemsnitlige statistiske risiko for indlæggelse, og metoden hvormed COVID-19 indlæggelser opgøres.

Estimeret nedre grænse for indlagte viser et interval mellem et muligt lavt og højt scenarie
",
    caption = "Kristoffer T. Bæk, covid19danmark.dk, datakilde: SSI") +
  scale_colour_brewer(palette = "Set2", name = "", guide = FALSE) +
  scale_fill_brewer(palette = "Set2", name = "",
                    labels = c("Observeret 7-dages gennemsnit", "Estimeret nedre grænse")) +
  standard_theme +
  theme(
    plot.title.position = "plot",
    plot.title = element_textbox_simple(
      size = 10, face = "plain", lineheight = 1.05, padding = margin(0, 5, 5, 0)
    )
  )

ggsave("../figures/ntl_admit_expected.png", width = 18, height = 10, units = "cm", dpi = 300)


#' twetbulb_j
#'
#' Estimating wet bulb temperature following  empirical equation given by Jeevananda, 1976.
#'
#' @param t numeric Air temperature in degC.
#' @param pair numeric Air Pressure in hPa. Default is 1010.
#' @return wet bulb temperature
#'
#'
#' @author Istituto per la Bioeconomia CNR Firenze Italy  Alfonso Crisci \email{alfonso.crisci@@ibe.cnr.it}
#' @keywords wet bulb temperature
#'
#' @export
#'
#'
#'
#'

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


Input = read.csv("D:/vaibhav/trend nxt/topgear/R Community/Pima_Indian/Pima Indians Diabetes Binary Classification dataset.csv", header = TRUE)
head(Input)
summary(Input)
colnames(Input)
str(Input)
logitfit = glm(Class.variable..0.or.1. ~ Number.of.times.pregnant + Plasma.glucose.concentration.a.2.hours.in.an.oral.glucose.tolerance.test + Diastolic.blood.pressure..mm.Hg. + Triceps.skin.fold.thickness..mm. + X2.Hour.serum.insulin..mu.U.ml. + Body.mass.index..weight.in.kg..height.in.m..2. + Diabetes.pedigree.function + Age..years., data=Input, family=binomial(logit))
summary(logitfit)
Model1Pred = round(predict(logitfit, Input, type="response"))
table(Input$Class.variable..0.or.1., Model1Pred)
Input$Predicted = Model1Pred
write.csv(Input, "D:/vaibhav/trend nxt/topgear/R Community/Pima_Indian/Output.csv")

R Community/Pima Indians Diabetes/code.r