eps=1e-4

gt_texttonum<-function(gtstr){
	x=strsplit(gtstr,":")[[1]][1]
	ans=0
	if(x=="0/1" || x=="0|1" || x=="1/0" || x=="1|0"){
		ans=1
	}
	else if(x=="1|1" || x=="1/1"){
		ans=2
	}
	else{
		ans=0
	}
	ans
}

boundf<-function(f){
	f1=f
	f1[f1<eps]=eps;f1[f1>1-eps]=1-eps
	f1
}

ll<-function(x,g,fmat){ #fmat=JxK
	qvec=x#c(x,1-sum(x))
	qmat=matrix(qvec,nrow=length(qvec),ncol=1,byrow=F) #Kx1
	fbar=boundf(c(fmat%*%qmat))
	-1*sum(g*log(fbar)+(2-g)*log(1-fbar))
}

gradll<-function(x,g,fmat){ #fmat=JxK
	qvec=x#c(x,1-sum(x))
	qmat=matrix(qvec,nrow=length(qvec),ncol=1,byrow=F)# Kx1
	fbar=boundf(c(fmat%*%qmat)) #Jx1
	gmat=matrix(g,ncol=length(qvec),nrow=length(g),byrow=F) # JxK
	fbarmat=matrix(fbar,nrow=length(fbar),ncol=length(qvec),byrow=F)
	gradvec=c(colSums( fmat*gmat/fbarmat+(2-gmat)*(1-fmat)/(1-fbarmat)))
	-1*gradvec
}

issumq1<-function(x,g,fmat){
	sum(x)-1
}

issumq1_g<-function(x,g,fmat){
	rep(1,length(x))
}

init_em<-function(g,fmat){
	K=dim(fmat)[2]
	xold=rep(1/K,K)
	xnew=xold
	gmat=matrix(g,ncol=K,nrow=length(g),byrow=F) # JxK
	for(i in 1:200 ){
		qmat=matrix(xold,nrow=K,ncol=1,byrow=F)# Kx1
		fbar=boundf(c(fmat%*%qmat)) #Jx1
		fbarmat=matrix(fbar,nrow=length(fbar),ncol=K,byrow=F)
		qmat2=matrix(xold,nrow=dim(fmat)[1],ncol=K,byrow=T)
		amat=qmat2*fmat/fbarmat
		bmat=qmat2*(1-fmat)/(1-fbarmat)
		xnew=colSums(gmat*amat+(2-gmat)*bmat)/(2*length(fbar))
		xnew=xnew/sum(xnew)
		#cat("EM:",i,xold,"--->",xnew,"=",sum(xnew),"\n")
		xold=boundf(xnew)
	}
	#cat("Initial guess is",xnew,"\n")
	boundf(xnew)
}

findq<-function(g,fmat){
	K=dim(fmat)[2]
	local_opts=list("algorithm"="NLOPT_LD_LBFGS","xtol_rel"=1e-7)
	opts=list("algorithm"="NLOPT_LD_SLSQP",print_level=0,maxeval=10000,xtol_rel=1e-7,ftol_abs=1e-10)
	x0=init_em(g,fmat)
	solobj=nloptr(x0=x0,eval_f=ll,eval_grad_f=gradll,eval_g_eq=issumq1,eval_jac_g_eq=issumq1_g,lb=rep(eps,K),ub=rep(1-eps,K),g=g,fmat=fmat,opts=opts)
	bestq=solobj$solution
	#print(solobj)
	#print(bestq)
	bestq
}

args<-commandArgs(T)
if(length(args)<2){
	stop("Usage:Rscript q_multipop_todistribute.r frequencyfile vcffile\n")
}

library("plyr")
#library("data.table")
library("nloptr")
#library("ade4")

frqfile<-args[[1]]
vcffile<-args[[2]]

frqtable<-read.table(frqfile,header=T)
vcffull<-read.table(vcffile,header=F,stringsAsFactors=F)
colnames(vcffull)[1:9]<-c('CHR','POS','ID','REF','ALT','QUAL','FILTER','INFO','FORMAT')

vcf=vcffull[,-1*c(3,6,7,8,9)]

ob=join(frqtable,vcf,type="left")
#head(ob)
#print(dim(frqtable))
#print(dim(ob))

poplist=c("AFR","ASN","AMR","SAN","EUR")
freq_subset=1-as.matrix(ob[,poplist])
nextracols=length(poplist)+4 # CHR,POS,REF,ALT
ans=c()
for(col in (nextracols+1):dim(ob)[2]){
gtvec_text=ob[,col]
gtvec_text[is.na(gtvec_text)]="0|0"

gtvec=sapply(gtvec_text,gt_texttonum)
#head(gtvec)

qvec=findq(gtvec,freq_subset)
names(qvec)<-poplist
#print(qvec)
ans=rbind(ans,qvec)
}
print(ans)


#' pca test for opencpu development
#'
#' a wrapper for pca test, starting from a csv imput, do the pca analysis, output some txt test.
#' the coordinate of the pca plot will be returned
#'
#' @param combo_target a csv file with row as observations, while column as experiment
#' @return  a list of sample name, and x,y coordinate
#'
#' @seealso \code{\link{prcomp}}
#'
#' @export
#'
#'

prcomp_opencpu_csv<-function(filename){
	# readin table
	taxon.table <-read.csv(filename, sep = "\t")

	# process
	rownames(taxon.table) <- taxon.table[,1]
	taxon.table <- taxon.table[,-1]
	taxon.table[taxon.table==0] <- NA
	taxon.table <-log10(taxon.table)
	cluster.result <-prcomp(t(na.omit(taxon.table)), scale = TRUE)$x

	# get values, and return, task finished!
	x <- cluster.result[,1]
	y <- cluster.result[,2]
	sample.name <- rownames(cluster.result)

	write.table(cluster.result,"value_cluster.txt",sep="\t",row.names = TRUE, col.names = NA)
	write.table(x,"value_x.txt",sep="\t",row.names = TRUE,col.names = NA)
	write.table(y,"value_y.txt",sep="\t",row.names = TRUE,col.names = NA)

	png("plot.png")
	myplot<-plot(x, y)
	myplot<-myplot+text(x,y, labels=sample.name, cex= 0.7, pos=3)
	print(myplot)
	dev.off()

	return(list(sample.name, x, y))
}


library(merkhet)
suppressMessages(library(fmlr))

m = n = 250
seed = 1234
type = "float"

# ------------------------------------------------------------------------------
header = sprintf("matprod - %dx%d (%s) type=%s", m, n, as.character(howbig(m, n, type=type)), type)
b = bench(header, flops=2*n^3)

tol = ifelse(type=="double", 1e-8, 1e-4)

x = cpumat(n, n, type)
x$fill_rnorm(seed)
xr = x$to_robj()

y = cpumat(n, n, type)
y$fill_rnorm()
yr = y$to_robj()

b$time({xr %*% yr}, name="R")

b$time(linalg_matmult(FALSE, FALSE, x=x, y=y), name="fmlr - CPU")

if (fml_gpu())
{
  c = card()
  xg = gpumat(c, type=type)
  cpu2gpu(x, xg)
  yg = gpumat(c, type=type)
  cpu2gpu(y, yg)

  b$time({
    linalg_matmult(FALSE, FALSE, x=xg, y=yg)
    c$synch()
  }, name="fmlr - GPU")
}

b$print()


#Dati

intervallo1 <- 1.74
intervallo2 <- 3.2
singoletto <- 13.33

denominatore <- 2.3216

domanda1 <- 1.92

domanda2_a <- 1.92
domanda2_b <- 2.06
domanda2_c <- 1.74
domanda2_d <- 3.2

domanda3_a <- 2.06
domanda3_b <- 2.1
domanda3_c <- 1.74
domanda3_d <- 1.92

#Svolgimento

EPSILON <- 0.001

f <- function(x) {
  ifelse(x < intervallo1, 0,
         ifelse(x >= intervallo1 && x < intervallo2, ((x - intervallo1)^2)/denominatore,
                ifelse(x >= intervallo2 && x < singoletto, 0.81,
                      ifelse(x >= singoletto, 1, NaN))))
}

f_calc <- function(x) {
  (x - intervallo1)^2/denominatore
}

par(bg = "black", fg = "White")
plot.new()
par(new = TRUE)
plot(Vectorize(f), xlab = "x", from = intervallo1-1, to = singoletto+1,
     type = "l", ylab = "F(x)", col = "Yellow2",
     col.axis = "white", col.lab = "white", lwd = 2)

for(i in seq(0, 1, 0.5)) {
  abline(h = i, lty="dotted", col = "Gray")
}

for(i in seq(0, singoletto+2, 0.5)) {
  abline(v = i, lty="dotted", col = "Gray")
}

domanda2 <- (f(domanda2_b)- f(domanda2_a))/(f(domanda2_d)-f(domanda2_c))

print(f(domanda1)-f(domanda1), digits=22)
print(domanda2, digits=22)
print(f(domanda3_b)-f(domanda3_a) + f(domanda3_d)- f(domanda3_c), digits=22)


#input <- "B3501_TYNE.txt"
data <- read.table(input, header = T)
#head(data)

Round <- round(cor(data) * 10)
write.table(Round, paste(input,"_R_0_round.txt"), quote = FALSE, sep = "\t")

#write.table(Pairs, quote = FALSE, sep = "\t")

pc1 <- prcomp(data, scale. = T)
rot <- pc1$r
x   <- pc1$x

#write.table(Summary, quote = FALSE, sep = "\t")

Rot <- round(rot * 10)
write.table(Rot, paste(input,"_R_1_rot.txt"), quote = FALSE, sep = "\t")

X <- round(x*10)
write.table(X, paste(input,"_R_2_X.txt"), quote = FALSE, sep = "\t")

Summary <- summary(pc1)

screeplot(pc1)

Pairs <- pairs(data, phc = ".", col = "blue")

file.rename("Rplots.pdf", paste(input,"_R_3_plot.pdf"));

quit()
n


library(R0)
library(uuid)
library(igraph)
library(ggnetwork)
library(data.table)
library(EpiDynamics)
library(scales)
library(tidyverse)

# https://www.ijidonline.com/article/S1201-9712(20)30119-3/pdf
weibull_mean = 6.4
# weibull_mean = 4.8
weibull_sd = 2.3
#
# > 10977 / (19e6 * .2)
# [1] 0.002888684

# get shape/scale for weibull distribution
fit_weibull = function(pars) {
  shape = pars[1]
  scale = pars[2]
  the_dist = rweibull(10000, shape, scale)
  the_sd = abs(sd(the_dist) - weibull_sd)
  the_mean =  abs(mean(the_dist) - weibull_mean)
  return(
    (the_sd * the_mean)^2
  )
}
weibull_params = optim(par = c(3, 7), fn = fit_weibull)
the_weibull_dist = rweibull(10000, weibull_params$par[1], weibull_params$par[2])
summary(the_weibull_dist)

fit_weibull_r0 = function(pars) {
  shape = pars[1]
  scale = pars[2]
  the_dist = rweibull(10000, shape, scale)
  mean_dist = mean(the_dist) - 2.5
  min_dist = min(the_dist) - 0.75

  return(
    (mean_dist)^2 + min_dist^2
  )
}
r0_params = optim(par = c(3, 7), fn = fit_weibull_r0)

run_case_simulation = function(initial_susceptible = 20e6, the_r0,
                               lockdown_date = NULL, lockdown_effect = NULL, r0_type = NULL) {
  this_r0 = the_r0
  current_susceptible = initial_susceptible

  case_info_list = list()

  generation = 0

  cases_gen_df = tibble(
    parent_id = NA,
    incubation_start = 0
  )
  n_cases_generated = 1

  continue_loop = T

  while (continue_loop) {
    loop_start = proc.time()

    # print(generation)

    if (n_cases_generated > current_susceptible) {
      # cat('too many cases generated!\n', n_cases_generated, '\n')
      n_cases_generated = current_susceptible
      suseptible_by_id = current_susceptible - 1:n_cases_generated
      # cat('n_cases_generated is now', n_cases_generated, '\n')
      cases_gen_df = head(cases_gen_df, n_cases_generated)
    } else {
      suseptible_by_id = current_susceptible - 1:n_cases_generated
    }
    # cat('n_cases_generated:', n_cases_generated, '\n')
    # cat('current_susceptible:', current_susceptible, '\n')
    #

    # suseptible_by_id = suseptible_by_id[suseptible_by_id > 0]

    if (current_susceptible < 0) {
      # cat('no more susceptible')
      break
    }

    the_id = initial_susceptible - suseptible_by_id
    # https://wwwnc.cdc.gov/eid/article/26/6/20-0357_article
    # https://www.ijidonline.com/article/S1201-9712(20)30119-3/pdf

    # incubation_time = rnorm(n_cases_generated, 3.96, 4.75)
    # incubation_time = rgamma(n_cases_generated, 4.37,  scale = 1.25)
    # incubation_time = rweibull(n_cases_generated, weibull_params$par[1], weibull_params$par[2])
    incubation_time = 5
    incubation_start_date = cases_gen_df$incubation_start
    incubation_end_date = incubation_start_date + incubation_time
    prob_running_into_someone_else = suseptible_by_id / initial_susceptible

    if (r0_type == 'weibull') {
      the_r0 = rweibull(n_cases_generated, r0_params$par[1], r0_params$par[2])
    } else if (r0_type == 'unif') {
      the_r0 = runif(n_cases_generated, this_r0*0.75, this_r0*1.25)
    }

    if (!is.null(lockdown_date)) {
      lockdown_effects = ifelse(incubation_start_date >= lockdown_date, lockdown_effect, 1)
      r0_adj = the_r0 * prob_running_into_someone_else * lockdown_effects
    } else {
      r0_adj = the_r0 * prob_running_into_someone_else
    }

    cases_generated = floor(r0_adj) + rbinom(length(r0_adj), 1, r0_adj - floor(r0_adj))
    n_cases_generated = sum(cases_generated)

    these_cases_df = data.table(
      the_id = the_id %>% as.integer(),
      generation = generation,
      parent_id = cases_gen_df$parent_id,
      incubation_time,
      incubation_start_date,
      incubation_end_date,
      prob_running_into_someone_else,
      r0_adj,
      cases_generated
    ) %>%
      setkey(the_id)

    case_info_list[[length(case_info_list) + 1]] = these_cases_df

    if (n_cases_generated > 0) {
      # important to sort by cases generated so the recyling works
      with_gen_cases = filter(these_cases_df, cases_generated > 0) %>% arrange(-cases_generated)

      cases_gen_df = data.table(
        parent_id = rep(with_gen_cases$the_id, length.out = n_cases_generated),
        incubation_start = runif(n_cases_generated, with_gen_cases$incubation_start_date, with_gen_cases$incubation_end_date)
      ) %>%
        setorder(incubation_start)

      stopifnot(nrow(cases_gen_df) == n_cases_generated)
    }

    # print(proc.time() - loop_start)
    generation = generation + 1
    current_susceptible = min(suseptible_by_id)
    continue_loop = n_cases_generated > 0 & current_susceptible > 0
  }

  case_info_df = rbindlist(case_info_list) %>%
    mutate(
      start_day = floor(incubation_start_date),
      end_day = floor(incubation_end_date)
    )
  return(rbindlist(case_info_list))
}

covid_ifr = 0.003
flu_ifr = 0.001
n_susceptible = 10e6

covid_case_simulation = run_case_simulation(r0_type = 'covid', the_r0 = 2.5,
                                            initial_susceptible = n_susceptible/2) %>%
  mutate(
    start_day = floor(incubation_start_date),
    died = rbinom(length(the_id), 1, covid_ifr),
    death_date = ifelse(died, start_day + 14, NA)
  )

generation_stats = group_by(covid_case_simulation, generation) %>%
  summarize(
    obs = n(),
    mean_cases = mean(cases_generated),
    mean_r0 = mean(r0_adj),
    mean_prob = mean(prob_running_into_someone_else ),
    min_prob = min(prob_running_into_someone_else),
    max_prob = max(prob_running_into_someone_else),
    start = min(incubation_start_date),
    end = max(incubation_end_date),
    mean_start = mean(incubation_start_date),
    mean_end = mean(incubation_end_date)
  )

ggplot(generation_stats, aes(start, max_prob, colour = factor(generation))) +
  geom_point() +
  geom_point(aes(y = min_prob))

covid_case_simulation$incubation_time
covid_case_simulation %>% pull(cases_generated) %>% summary()

ggplot(covid_case_simulation, aes(incubation_start_date, cases_generated, size = r0_adj)) +
  geom_point()

incubation_period = 5
initial_r0 = 2.5
gamma = 1/incubation_period
initial_beta = initial_r0 / incubation_period
initial_parameters <- c(beta = initial_beta, gamma = gamma)
initials <- c(S = 1 - 1e-06, I = 1e-06, R = 1 - (1 - 1e-06 - 1e-06))
# initials <- c(S = 1 - 1e-06, I = 1e-06, R = 1 - (1 - 1e-06 - 1e-06))
initial_covid_sir <- SIR(pars = initial_parameters, init = initials, time = 0:240)

counts_by_day = group_by(covid_case_simulation, start_day) %>%
  summarize(
    obs = n_distinct(the_id)
  )

sir_results =  initial_covid_sir$results %>%
  mutate(
    n_susceptible = n_susceptible/2 * S,
    n_cases = lag(n_susceptible, 1) - n_susceptible
  )
b = left_join(sir_results, counts_by_day, by = c('time' = 'start_day')) %>%
  mutate(
    obs= ifelse(is.na(obs), 0, obs),
    n_cases = ifelse(is.na(n_cases), 0, n_cases)
  )
with(b, cor(obs, n_cases))

ggplot(counts_by_day, aes(start_day, obs)) +
  geom_area(alpha = 0.3) +
  geom_area(data = sir_results, aes(time, n_cases), alpha = 0.3, fill = 'blue') +
  scale_y_continuous(labels = comma)

covid_case_simulation_lockdown = run_case_simulation(the_r0 = 2.5, r0_type = 'covid',
                                                     lockdown_date = 15, lockdown_effect = 0.65,
                                                     initial_susceptible = n_susceptible/2) %>%
  mutate(
    start_day = floor(incubation_start_date),
    died = rbinom(length(the_id), 1, covid_ifr),
    death_date = ifelse(died, start_day + 14, NA)
  )

flu_case_simulation = run_case_simulation(the_r0 = 1.3, r0_type = 'flu',
                                          initial_susceptible = 327e6/4) %>%
  mutate(
    start_day = floor(incubation_start_date),
    died = rbinom(length(the_id), 1, flu_ifr),
    death_date = ifelse(died, start_day + 14, NA)
  )

covid_cases_by_day = dplyr::group_by(covid_case_simulation, start_day) %>%
  dplyr::summarize(
    obs = n_distinct(the_id),
    died = sum(died)
  ) %>%
  mutate(
    cum_obs = cumsum(obs),
    Virus = 'COVID-19',
    with_lockdown = 'No'
  )

covid_cases_by_day_lockdown = dplyr::group_by(covid_case_simulation_lockdown, start_day) %>%
  dplyr::summarize(
    obs = n_distinct(the_id),
    died = sum(died)
  ) %>%
  mutate(
    cum_obs = cumsum(obs),
    Virus = 'COVID-19 Early Lockdown',
    with_lockdown = 'Yes'
  )

flu_cases_by_day = dplyr::group_by(flu_case_simulation, start_day) %>%
  dplyr::summarize(
    obs = n_distinct(the_id),
    died = sum(died)
  ) %>%
  mutate(
    cum_obs = cumsum(obs),
    Virus = 'Influenza',
    with_lockdown = 'No'
  )
sum(flu_cases_by_day$died)

stacked_stats = bind_rows(
  covid_cases_by_day, flu_cases_by_day,
  covid_cases_by_day_lockdown) %>%
  mutate(
    week = start_day %/% 7
  )

group_by(stacked_stats, Virus, with_lockdown) %>%
  summarize(
    t_obs = sum(obs),
    pct_infected = t_obs / n_susceptible,
    t_died = sum(died),
    crude_mortality_rate = t_died / n_susceptible,
    infection_fatality_rate = t_died / t_obs,
    time_period = as.numeric(max(start_day)-min(start_day))
  )
weekly_stats = group_by(stacked_stats, week, Virus, with_lockdown) %>%
  summarize(
    weekly_deaths = sum(died),
    weekly_cases = sum(obs)
  )
max(weekly_stats$weekly_deaths * 32.7)

ggplot(stacked_stats, aes(start_day, obs, fill = Virus)) +
  geom_area(alpha = 0.3, position = 'identity')

ggplot(weekly_stats, aes(week, weekly_deaths*32.7, colour = Virus)) +
  # facet_wrap(~Virus, scales = 'free_y') +
  geom_line() +
  geom_point()
  # geom_bar(stat = 'identity', position = 'identity')

# mGT_weibull <- generation.time("weibull", c(6.4, 2.3))
# mGT_weibull <- generation.time("gamma", c(5, 1.5))
# est.R0.EG(cases_by_day$obs, mGT_weibull, t = cases_by_day$start_day, begin = 0, end = 20)
#


Copyright (c) 2015-2016 Tung Shuo Wu

Email: tommywu6@hotmail.com

#.............................................................
Acknowledgements.
I would like to express my sincere thanks to Professor Wei-Wen Wu and Hau-Ting Nian for helping the completion of this R code in terms of DEMATEL.

#.............................................................

setwd("")
Z=read.csv("myfile.csv", header=TRUE, sep=",", row.names=1)
D=c(); R=c()
maxsum=sum(Z[1,])
for (i in 1:nrow(Z)) {
   maxsum=max(maxsum, sum(Z[i,]))
}
X=Z/maxsum
X1= diag(nrow(X)) - X
X2=solve(X1)
T = as.matrix(X) %*%X2
for (i in 1:nrow(T)) {
   D[i]=sum(T[i,])
}
for (i in 1:ncol(T)) {
   R[i]=sum(T[,i])
}
x=D+R; y=D-R
Criterion = row(Z)[,1]
df=data.frame(Criterion, D,R, x, y)
df$Criterion = paste("C", Criterion, sep="")
colnames(df)<-c("Criterion", "D","R", "D+R", "D-R")
plot(x, y, type='p',
main="DEMATEL & XXX Model ", sub="The causal diagram",xlab="D+R", ylab="D-R",cex=0.6)
abline(h=mean(y),v=mean(x))
text(x, y, df$Criterion)
View(df)


accuracy = function(mod, X, Y){
  mean(Y == predict_model(mod, X, type="class") )
}

# Just setting as type = "class" for testing purposes.
rsqrd = function(mod, X, Y, type="class"){
  outv <- summary(mod)$r.squared
  if(is.null(outv)){
    Y_bar  = mean(Y)
    Y_pred = predict_model(mod, X, type=type)
    # via WP
    SS_tot = sum((Y      - Y_bar)^2)
    SS_reg = sum((Y_pred - Y_bar)^2)
    SS_res = sum((Y      - Y_pred)^2)
    outv = 1 - (SS_res / SS_tot)
  }
  outv
}

# Add more stats later
statistics = list(accuracy = accuracy,
                  rsqrd=rsqrd)


#' Iterator that maps a function to a sequence of numeric values
#'
#' Constructs an iterator that maps a given function over an indefinite sequence
#' of numeric values. The input the function \code{f} is expected to accept a
#' single numeric argument. The sequence of arguments passed to \code{f} begin
#' with \code{start} and are incremented by \code{step}.
#'
#' @export
#' @param f the function to apply
#' @param start sequence's initial value
#' @param step sequence's step size
#' @return an iterator that returns the mapped values from the sequence
#'
#' @examples
#' it <- itabulate(f=function(x) x + 1)
#' take(it, 4) # 2 3 4 5
#'
#' it2 <- itabulate(f=function(x) x^2, start=-3)
#' take(it2, 6) # 9 4 1 0 1 4
#'
#' it3 <- itabulate(abs, start=-5, step=2)
#' take(it3, 6) # 5 3 1 1 3 5
#'
#' it4 <- itabulate(exp, start=6, step=-2)
#' take(it4, 4) # exp(c(6, 4, 2, 0))
#'
itabulate <- function(f, start=1, step=1) {
  start <- as.numeric(start)
  step <- as.numeric(step)

  if (length(start) != 1) {
    stop("'start' must be a numeric value of length 1")
  }
  if (length(step) != 1) {
    stop("'step' must be a numeric value of length 1")
  }

  imap(f=f, icount(start=start, step=step))
}


#' Results from drawing different color balls from an urn
#'
#' @param n.iter The number of iterations in the monte carlo simulation (integer > 0)
#' @param n.colors The number of different colored balls (integer > 0)
#' @param n.balls The count of each color balls (vector of integers with same length as \code{n.colors})
#' @param n.drawn The number of balls drawn from the urn in each iteration
#' @param replacement Are the balls placed back in the urn after they're drawn? (defaults to \code{FALSE})
#' @param collapse Should the return be the draws or the count of each color? (defaults to \code{FALSE})
#' @param parallel Should the simulation take advantage of multiple cores (defaults to \code{TRUE} -
#'   highly recommended if \code{n.iter > 1e5})
#'
#' @return If \code{collapse == TRUE} the return is a \code{n.iter x n.colors} integer matrix
#'   where each row is the count of the colors of balls drawn. Otherwise, the return is a
#'   \code{n.iter x n.drawn} integer matrix where each row is the order that colors were drawn in.
#' @export
#'
draw.urn = function(n.iter = 1e5, n.colors = 2, n.balls = c(10,10),
                    n.drawn = 5, replacement = FALSE,
                    collapse = FALSE, parallel = TRUE) {
  stopifnot(n.iter %% 1 == 0 & n.iter > 0)
  stopifnot(n.colors %% 1 == 0 & n.colors > 0)
  stopifnot(all(n.balls %% 1 == 0) & all(n.balls > 0))
  stopifnot(length(n.balls) == n.colors)
  stopifnot(n.drawn %% 1 == 0 & n.drawn > 0)
  urn = unlist(lapply(seq_len(n.colors), FUN = function(i) rep(i, n.balls[i])))
  total.balls = sum(n.balls)
  if(!parallel) {
    results = lapply(seq_len(n.iter), FUN = function(i) {
      indices = sample(seq_len(total.balls), size = n.drawn, replace = replacement)
      urn[indices]
    })
  } else {
    results = mclapply(seq_len(n.iter), FUN = function(i) {
      indices = sample(seq_len(total.balls), size = n.drawn, replace = replacement)
      urn[indices]
    })
  }
  if(collapse) {
    return(t(sapply(results, FUN = function(x) {
      vapply(seq_len(n.colors), function(i) sum(x == i),1)
    })))
  }
  return(do.call(rbind, results))
}


mydata = read.csv("Big Mart Dataset - Sheet1.csv")
mydata

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

#ScatterPlot
#used to see relationship between two continuous variables

#In the dataset, if we want to visualise the iterms as per their
#cost data, then we can use scatterplot using two continuous variable
#Item_Visibility and Item_MRP

library(ggplot2)
 #Example 1
ggplot(mydata, aes(Item_Visibility, Item_MRP)) +
  geom_point() + scale_x_continuous("Item_Visibility", breaks = seq(0,0.35,0.05))+
  scale_y_continuous("Item_MRP", breaks = seq(0, 270, by = 30))+theme_bw()

#aes(x,y)
#scale_x_continuous("Tag", breaks)
#breaks: to control the breaks in the guide
#     NULL: hide all breaks
#     waiver(): the default break computation
#     a char or numeric vector to specify the breaks to display

#Example 2
#Addition of a categorical variable(Item_Type)
ggplot(mydata, aes(Item_Visibility, Item_MRP)) +
  geom_point(aes(color = Item_Type)) +
  scale_x_continuous("Item Visibility", breaks = seq(0, 0.35, 0.05)) +
  scale_y_continuous("Item_MRP", breaks = seq(0,270,by = 30)) +
  theme_bw() + labs(title = "ScatterPlot")

#Example 3
#Separate Category wise Chart

ggplot(mydata, aes(Item_Visibility, Item_MRP)) +
  geom_point(aes(color = Item_Type)) +
  scale_x_continuous("Item Visibility", breaks = seq(0, 0.35, 0.05)) +
  scale_y_continuous("Item MRP", breaks = seq(0,270, by = 30)) +
  theme_bw() + labs(title = "ScatterPlot") + facet_wrap(~Item_Type)

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

# Histogram
#Used to plot continuous variable. Breaks data into bins and shows their
#frequencies.

ggplot(mydata, aes(Item_MRP)) + geom_histogram(binwidth = 2) +
  scale_x_continuous("Item MRP", breaks = seq(0,270,by = 30)) +
  scale_y_continuous("Count", breaks = seq(0,200, by = 20)) +
  labs(title = "Histogram")

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

#Bar and Stack Bar Chart
#Bar charts are used when you want to plot a categorical variable or a
#combination of continuous and categorical variable

#Example: Number of Marts established in a particular year

#For a single continuous variable
ggplot(mydata, aes(Outlet_Establishment_Year)) +
  geom_bar(fill = "red") + theme_bw() +
  scale_x_continuous("Establishment Year", breaks = seq(1985, 2010)) +
  scale_y_continuous("Count", breaks = seq(0, 1500, 150))+
  coord_flip() + labs(title = "Bar Chart") + theme_gray()

#Without "coord_flip()"
ggplot(mydata, aes(Outlet_Establishment_Year)) +
  geom_bar(fill = "red") + theme_bw() +
  scale_x_continuous("Establishment Year", breaks = seq(1985, 2010)) +
  scale_y_continuous("Count", breaks = seq(0, 1500, 150))+
   labs(title = "Bar Chart") + theme_gray()

#Example 3
ggplot(mydata, aes(Item_Type, Item_Weight)) +
  geom_bar(stat = "identity", fill = "darkblue") +
  scale_x_discrete("Outlet Type") +
  scale_y_continuous("Item Weight", breaks = seq(0, 15000, by = 500)) +
  theme(axis.text.x = element_text(angle = 90, vjust = 0.5)) +
  labs("Bar Chart")

#Example 4
#Stacked Bar Chart
#Used to visualise a combination of categorical variable

ggplot(mydata, aes(Outlet_Location_Type, fill = Outlet_Type)) + geom_bar() +
  labs(title = "Stacked Bar Chart", x = "Outlet Location Type",
       y = "Count of Outlets")

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

#Box Plot
#Used to plot a combination of categorical and continuous variables.
#This plot is useful for visualizing the spread of the data and detect
#outliers. It shows five statistically significant numbers- the minimum,
#the 25th percentile, the median, the 75th percentile and the maximum.

ggplot(mydata, aes(Outlet_Identifier, Item_Outlet_Sales)) +
  geom_boxplot(fill = "red") +
  scale_y_continuous("Item Outlet Sales", breaks = seq(0,15000, by=500))+
  labs(title="Box Plot", x = "Outlet Identifier")

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

#Area Chart
#Used to show continuity across a variable or data set.

ggplot(mydata, aes(Item_Outlet_Sales)) + geom_area(stat = "bin", bins=30, fill = "red")+
  scale_x_continuous(breaks = seq(0,11000, 1000)) +
  labs(title = "Area Chart", x = "Item Outlet Sales", y = "Count")

#In geom_area(position, stat)
#position: Position Adjustments to points
#stat: Statistical Transformation to use on the data for this layer
#bins: Equal parts in which the data set is divided into, basically
#       class intervals.

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

#HeatMaps

#Uses Intensity of colors to display relationship between multiple variables
#Basically presents 3 dimensions to analyse

#Example: We want to know cost of each item on every outlet,
#         use: Item MRP, Outlet Identifier, Item Type

ggplot(mydata, aes(Outlet_Identifier, Item_Type)) +
  geom_raster(aes(fill = Item_MRP)) +
  labs(title="HeatMap", x = "Outlet Identifier", y = "Item Type") +
  scale_fill_continuous(name = "Item MRP")

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


library(MDPtoolbox)

P <- array(0, c(3,3,2))
P[,,1] <- matrix(c(0.2, 0.8, 0, 0.3,0,0.7,0.4,0,0.6), 3, 3, byrow=TRUE)
P[,,2] <- matrix(c(1, 0, 0, 1, 0, 0,1, 0, 0), 3, 3, byrow=TRUE)
R <- matrix(c(3, 1, 2, 2,1,3), 3, 2, byrow=TRUE)

mdp_check(P, R)

QLearnModel=mdp_Q_learning(P=P, R=R, discount = 0.95)

print(QLearnModel$Q)
print(QLearnModel$V)
print(QLearnModel$policy)
print(QLearnModel$mean_discrepancy)


# Specify model
library("rjags")

# model structure
# normal likelyhood
# prior on mean t distribution

#must  write model as a string
mod_string = " model {
    for (i in 1:n){
        y[i] ~ dnorm(mu, 1.0/sig2)
    }
    mu ~ dt(0.0, 1.0/1.0, 1)
    sig2 = 1.0
} "

# model set up
set.seed(50)
y =  c(1.2, 1.4, -0.5, 0.3, 0.9, 2.3, 1.0, 0.1, 1.3, 1.9)
n = length(y)

data_jags = list(y=y, n=n)
params = c("mu")

inits = function(){
    inits = list("mu"=0.0) # could generate a random mu
}

mod = jags.model(textConnection(mod_string), data=data_jags, inits=inits)

# Run MCMC sampler
update(mod, 500)

mod_sim = coda.samples(model=mod, variable.names=params, n.iter = 1000) #simulate markov chain

# Post processing, evaluate markov chain and use for inference
library("coda")

plot(mod_sim)
summary(mod_sim)


x = seq(-5,5,by=0.01)
sizeLimit = function(n,x) {q=pnorm(x);4*sum(counts)*q*(1-q)/50}
addPoint = function(p) {
    dist = abs(centroids - p)
    k = which(min(dist) == dist)[1]
    if (counts[k] < sizeLimit(N, p)) {
        counts[k] <<- counts[k]+1
        centroids[k] <<- centroids[k] + (p-centroids[k]) / counts[k]
    } else {
        centroids <<- c(centroids, p)
        counts <<- c(counts, 1)
    }
}

offset = 100
step = function(n=100) {
    for (i in 1:n) {
        addPoint(samples[i+offset])
    }
    offset <<- offset + n
    counts
}

plot(x, sizeLimit(40, x), type='l')

N = 10e6
samples = rnorm(N)
centroids = samples[1:2]
counts = (centroids != 1000) + 0

plot.offset = 0
plot.stuff = function(stepSize=1000) {
    for (i in 1:10) {
        step(stepSize)
        pdf(sprintf("fig-%03d.pdf", i + plot.offset),
            width=5, height=5, pointsize=10)
        plot(pnorm(centroids[order(centroids)]), counts[order(centroids)],
             type='p', ylim=c(0, 2*max(counts)),
             pch=21, bg=rgb(0,0,0,alpha=0.1), col=rgb(0,0,0,alpha=0.1), cex=0.6);
        centers = centroids[order(centroids)]
        limits = sizeLimit(sum(counts), centers)
        lines(pnorm(centers), limits, type='l')
        dev.off()
    }
    plot.offset <<- plot.offset + 10
}

plot.stuff(100)
plot.stuff(1000)
plot.stuff(10000)
plot.stuff(100000)


library(MDPtoolbox)

MoveUp=matrix(c(0.3, 0.7, 0, 0,
            0, 0.9, 0.1, 0,
            0, 0.1, 0.9, 0,
            0, 0, 0.7, 0.3),
          nrow=4,ncol=4,byrow=TRUE)

MoveDown=matrix(c( 1, 0, 0, 0,
               0.7, 0.2, 0.1, 0,
               0, 0.1, 0.2, 0.7,
               0, 0, 0, 1),
            nrow=4,ncol=4,byrow=TRUE)

MoveLeft=matrix(c( 0.9, 0.1, 0, 0,
               0.1, 0.9, 0, 0,
               0, 0.7, 0.2, 0.1,
               0, 0, 0.1, 0.9),
            nrow=4,ncol=4,byrow=TRUE)

MoveRight=matrix(c( 0.9, 0.1, 0, 0,
                0.1, 0.2, 0.7, 0,
                0, 0, 0.9, 0.1,
                0, 0, 0.1, 0.9),
             nrow=4,ncol=4,byrow=TRUE)

AllActions=list(up=MoveUp, down=MoveDown, left=MoveLeft, right=MoveRight)

AllRewards=matrix(c( -2, -2, -2, -2,
                  -2, -2, -2, -2,
                  -2, -2, -2, -2,
                  20, 20, 20, 20),
               nrow=4,ncol=4,byrow=TRUE)

mdp_check(AllActions, AllRewards)

GridModel=mdp_policy_iteration(P=AllActions, R=AllRewards, discount = 0.1)

GridModel$policy
names(AllActions)[GridModel$policy]

GridModel$V

GridModel$iter

GridModel$time


#' @export
#' @title dist.plt
#' @description plots distributions in R, useful for setting up priors in Bayesian analyses
#' @param \code{dist}
#' @param \code{par1}
#' @param \code{par2}
#' @param \code{x}
#' @param \code{xl}
#' @param \code{col}
#' @return \code{add}
#' @return \code{alpha}
#' @return \code{plot.lines}
#' @family plotting
#' @author  unknown, \email{<unknown>@@dfo-mpo.gc.ca}
#' @export
dist.plt<-function(dist="beta",par1,par2,x,xl=c(0,1),col=1,add=F,alpha=0.05,plot.lines=F,title=''){

	z<-get(paste("r",dist,sep=''))(1000,par1,par2)
	if(missing(xl))xl<-range(z)
	if(missing(x))x<-seq(xl[1],xl[2],length=1000)
	y<-get(paste("d",dist,sep=''))(x,par1,par2)

	if(add==F){
#		plot.new()
		plot(x,y,type='l',col=col,xlab='',ylab='',main=title)
	}

	if(add==T)lines(x,y,col=col)
	out<-list(c(quantile(z, alpha/2),quantile(z, 0.5),quantile(z, 1-alpha/2)),mode=x[which(y==max(y))],mean=mean(z),var=var(z))
	if(plot.lines){
  	abline(v=out[[1]][2],lty=2)
	abline(v=out$mean,lty=3)
	abline(v=out$mode,lty=4)
	}

	out

}


library(dslabs)
data(murders)

# basic plot function

x <- murders$population
y <- murders$total * 10^6
plot(x, y)

# for a quick plot that avoids accessing variables twice,
# we can use the `with` function.
# it lets us use the `murders` column names in the `plot` function.
# it also works with any data frames and any function.

with(murders, plot(population, total))

# it's simple to make a histogram using `hist` function:

x <- with(murders, total / population * 10^6)
hist(x)

# boxplots can be used to compare data:

murders$rate <- with(murders, total / population * 10^6)
boxplot(rate~region, data = murders)

# the image function displays the values in a matrix using color:

x <- matrix(1:120, 12, 10)
image(x)


set.seed(1234, kind="Mersenne-Twister")

## Easier if the string is a character vector
target <- unlist(strsplit("METHINKS IT IS LIKE A WEASEL", ""))

charset <- c(LETTERS, " ")
parent <- sample(charset, length(target), replace=TRUE)

mutaterate <- 0.01

## Number of offspring in each generation
C <- 100

## Hamming distance between strings normalized by string length is used
## as the fitness function.
fitness <- function(parent, target) {
    sum(parent == target) / length(target)
}

mutate <- function(parent, rate, charset) {
    p <- runif(length(parent))
    nMutants <- sum(p < rate)
    if (nMutants) {
        parent[ p < rate ] <- sample(charset, nMutants, replace=TRUE)
    }
    parent
}

evolve <- function(parent, mutate, fitness, C, mutaterate, charset) {
    children <- replicate(C, mutate(parent, mutaterate, charset),
                          simplify=FALSE)
    children <- c(list(parent), children)
    children[[which.max(sapply(children, fitness, target=target))]]
}

.printGen <- function(parent, target, gen) {
    cat(format(i, width=3),
        formatC(fitness(parent, target), digits=2, format="f"),
        paste(parent, collapse=""), "\n")
}

i <- 0
.printGen(parent, target, i)
while ( ! all(parent == target)) {
    i <- i + 1
    parent <- evolve(parent, mutate, fitness, C, mutaterate, charset)

    if (i %% 20 == 0) {
        .printGen(parent, target, i)
    }
}
.printGen(parent, target, i)


library(dslabs)
data(murders)

pop <<- sort(murders$population, decreasing = TRUE)
# Define a variable states to be the state names from the murders data frame
states <<- murders$state[order(murders$population, decreasing = TRUE)]

# Define a variable ranks to determine the population size ranks
ranks <<- rank(murders$population)

# Define a variable ind to store the indexes needed to order the population values
ind <<- order(ranks)

# Create a data frame my_df with the state name and its rank and ordered from least populous to most
my_df <<- data.frame(STATES = states, POP = pop, POP_RANK = ranks[ind])
my_df


 DTRSNA Example Program Results

 S
       9.9E-01    7.0E-01    7.0E-01    5.7E-01

 SEP
       6.3E-01    3.7E-01    3.7E-01    3.1E-01

 Approximate error estimates for eigenvalues of T (machine-dependent)
       1.9E-16    2.7E-16    2.7E-16    3.4E-16

 Approximate error estimates for right eigenvectors of T (machine-dependent)
       3.1E-16    5.1E-16    5.1E-16    6.1E-16


ratios = hofcon / seq_along(hofcon)

message("Maxima:")
print(sapply(1 : 20, function(pwr)
   max(ratios[2^(pwr - 1) : 2^pwr])))

message("Prize-winning point:")
print(max(which(ratios >= .55)))


# Heuristic Models
# Look at the Seattle weather in the data folder.
# Come up with a heuristic model to predict if it will rain today.
# Keep in mind this is a time series, which means that you only know what happened historically (before a given date).
# One example of a heuristic model is: It will rain tomorrow if it rained more than 1 inch (>1.0 PRCP) today.
# Describe your heuristic model in the next cell.

# Your model here:

# Examples:

# If rained yesterday it will rain today.
# If it rained yesterday or the day before it will rain today.

# Here is an example of how to build and populate a hurestic model:

df <- read_csv('https://github.com/gumdropsteve/datasets/raw/master/seattle_weather_1948-2017.csv')
df[is.na(df)]<-0

# Create an empty dataframe
heuristic_df<-data.frame(matrix(, nrow=nrow(df)-2, ncol=0))
heuristic_df$Yesterday<-0
heuristic_df$Today<-0
heuristic_df$Tomorrow<-0
heuristic_df$Guess<-FALSE
heuristic_df$Rain_tomorrow<-FALSE
heuristic_df$Correct<-FALSE

# View first 10 rows of each dataframe
head(df, 10)
head(heuristic_df, 10)

# Build a loop to add your heuristic model guesses as a column to this dataframe

# Here is an example loop that populates the dataframe created earlier
# with the total percip from yesterday and today
# then the guess is set to true if rained both yesterday and today

for(z in seq(1,nrow(df)-2,1)) {
  #start at time 2 in the data frame
  i <- z + 2

  #pull values from the dataframe
  yesterday <- df[(i-2),2]
  today <- df[(i-1),2]
  tomorrow <- df[i,2]
  rain_tomorrow <- tomorrow>0

  heuristic_df[z,1] <- yesterday
  heuristic_df[z,2] <- today
  heuristic_df[z,3] <- tomorrow
  heuristic_df[z,4] <- FALSE # set guess default to False
  heuristic_df[z,5] <- rain_tomorrow

  ######### uncomment and create your heuristic guess ################
  #if( ##### your conditions here #########){
  #    heuristic_df[z,4] <- TRUE
  # }
  ####################################################################

  if(heuristic_df[z,4] == heuristic_df[z,5])  heuristic_df[z,6] <- TRUE
  else heuristic_df[z,6] <- FALSE
}

#Evaluate the performance of the Heuristic model
#the accuracy of your predicitions

sum(heuristic_df$Correct)/nrow(heuristic_df)


install.packages("psych")
install.packages("pastecs")
install.packages("dplyr")
install.packages("ggplot2")
install.packages("corrplot")
install.packages("descr")
install.packages("car")
install.packages("MASS")
install.packages("caret")
install.packages("glmnet")
install.packages("BLR")
install.packages("lars")
install.packages("corrplot")
install.packages("ggpubr")
install.packages("GGally")
install.packages("BCA")
install.packages("backports")

library(corrplot)
library(lars)
library(BLR)
library(glmnet)
library(caret)
library(MASS)
library(car)
library(stats)
library(descr)
library(corrplot)
library(ggplot2)
library(dplyr)
library(psych)
library(pastecs)
library(dplyr)
library(ggpubr)
library(GGally)

# setwd(dir = "/Users/gvalderrama/Documents/Studio/diabetes")
# setwd(dir = "/Users/gregory/Documents/pucp/diabetes")
setwd(dir = "f://diabetes")

data <- read.csv(file="data.csv", header=TRUE, sep=",",
                 colClasses = c("character"))

data$EDAD <- as.numeric(data$EDAD)
data$TIEMPODIAG <- as.numeric(data$TIEMPODIAG)
data$PESO <- as.numeric(data$PESO)
data$TALLA <- as.numeric(data$TALLA)
data$IMC <- as.numeric(data$IMC)
data$HEMOGLOBINA <- as.numeric(data$HEMOGLOBINA)
data$GLICOSILADA <- as.numeric(data$GLICOSILADA)
data$TRIGLICERIDOS <- as.numeric(data$TRIGLICERIDOS)
data$COLESTEROL <- as.numeric(data$COLESTEROL)
data$HDL <- as.numeric(data$HDL)
data$ALBUMINA <- as.numeric(data$ALBUMINA)
data$BUN <- as.numeric(data$BUN)
data$UREA <- as.numeric(data$UREA)
data$CREATININA <- as.numeric(data$CREATININA)
data$TFGCKD <- as.numeric(data$TFGCKD)
data$TFGMDRD <- as.numeric(data$TFGMDRD)

dim(data)
str(data)
names(data)
head(data)
summary(data)

#TFG = EDAD , SEXO, CRERATENINA
# filter(data, SEXO == "F")
data_selected <- select(data, -(EDAD), -(PESO) , - (TALLA), -(ALIAS), -(SEXO), -(ECIVIL), -(TRATAMIENTO), -(HTA), -(PIEDIABETICO), -(TFGMDRD), -(CREATININA))
data_selected_extend <- select(data, -(EDAD), -(PESO) , - (TALLA), -(ALIAS), -(SEXO), -(TRATAMIENTO), -(HTA), -(PIEDIABETICO), -(TFGMDRD), -(CREATININA))
describe(data_selected)
names(data_selected)
colnames(data_selected) <- c("TIE", "IMC", "HEMO", "GLI", "TRI", "COL", "HDL", "ALB","BUN", "URE",  "TFG" )

ggdensity(data_selected$TIE, main = "Densidad de tiempo diagnostico",xlab = "Tiempo Diagnostico")
ggqqplot(data_selected$TIE)
shapiro.test(data_selected$TIE)
ggdensity(data_selected$IMC, main = "Densidad de tiempo diagnostico",xlab = "Tiempo Diagnostico")
ggqqplot(data_selected$IMC)
ggdensity(data_selected$BUN, main = "Densidad de tiempo diagnostico",xlab = "Tiempo Diagnostico")
ggqqplot(data_selected$BUN)

# z standarization para una mejor visualizacion

data_scaled <- as.data.frame(scale(data_selected))

boxplot(data_scaled)

boxplot.stats(data_scaled$TIE)

#correlaciones
cor(data_scaled)
# las columnas con mayor corelacion lineal
hist(data_scaled$TFG)
hist(data_scaled$BUN)
hist(data_scaled$GLI)
hist(data_scaled$HEMO)
hist(data_scaled$IMC)

plot(data_scaled$URE , data_scaled$TFG)

ggplot(data_selected, aes( x = BUN, y = TFG)) + geom_point(shape=1) + geom_smooth(method=lm)
ggpairs(data_selected) # cor  + graph

names(data_selected_extend)
table(data_selected_extend$ECIVIL)
ggpairs(data_selected_extend , title="Casado R Soltero G",  mapping=ggplot2::aes(colour = ECIVIL)) # cor  + graph

plot(data_selected$BUN , data_selected$TFG)
abline(lm(TFG ~ BUN, data =  data_selected), col="red") #regresion line
lines(lowess(data_selected$BUN, data_selected$TFG ), col="blue") #polynomial regresion

scatterplot(TFGCKD ~ BUN, data = data_selected_extend)

pairs(~TFG + BUN + HEMO , data = data_selected,  main = "simple" )
scatterplotMatrix(~TFG + BUN + HEMO , data = data_selected,  main = "simple" )

plot(data_scaled$GLI , data_scaled$TFG)
plot(data_scaled$HEMO , data_scaled$TFG)
plot(data_scaled$IMC , data_scaled$TFG)

#exploracion stepwise

Lm1 <- lm(TFG ~ ., data = data_selected)
summary(Lm1)
Slm1 <- step(Lm1)
summary(Slm1)
Slm1$anova

lm_URE_TFG = lm(  data_scaled$TFG ~ data_scaled$URE , data = data_scaled)
summary(lm_URE_TFG)
plot(data_scaled$URE , data_scaled$TFG)
abline(lm_URE_TFG)

par(mfrow=c(2,2))
plot(lm_URE_TFG)

par(mfrow=c(1,1))
plot(lm_URE_TFG,which=5)

lm_BUN_TFG = lm(  data_scaled$TFG ~ data_scaled$BUN , data = data_scaled)
summary(lm_BUN_TFG)
plot(data_scaled$BUN , data_scaled$TFG, cex = 1.3,lwd = 2)
abline(lm_BUN_TFG,lwd=3)

names(lm_URE_TFG$coefficients)
stem(lm_URE_TFG$residuals)
abline(a=0,b=0)
stem(Residual)

distinct( select (data, ECIVIL))
distinct( select (data, TRATAMIENTO))
distinct( select (data, PIEDIABETICO))

summarise(data_a, tiempodm_mean = mean(TIEMPODM))

summarise(group_by(data_a, PIEDIABETICO), tipo = n_distinct(PIEDIABETICO), pie = n())

plot(data_a$SEXO)

sample_n(data_a, 10)

sex <- factor(data_a$SEXO, levels=c("F", "M"), labels=c("Femenino", "Masculino"))

head(data)

final_data = data.frame(ALIAS = as.character(data$ALIAS),
                        EDAD =as.numeric(data$EDAD),
                        SEXO = factor(data$SEXO, levels=c("F", "M"), labels=c("Femenino", "Masculino")),
                        ECIVIL = factor(data$ECIVIL, levels=c("SOLTERO", "CASADO", "VIUDO"), labels=c("Soltero", "Casado", "Viudo")),
                        TIEMPODM = as.numeric(data$TIEMPODM),
                        PESO = as.numeric(data$PESO),
                        TALLA = as.numeric(data$TALLA)
)

head(final_data)

boxplot(final_data$EDAD, main = "Edad", ylab= "years" )
quantile(final_data$EDAD, p=c(.05, .25, .5, .75, .95))

hist(final_data$EDAD, main = "Edad", ylab= "pacientes", xlab = "edad" )

counts <- table(final_data$ECIVIL)
barplot(counts, main="Edad Pacientes",
        xlab="Number of Gears")

dotchart(final_data$EDAD)

#correlation

d <-  select(final_data, EDAD , TIEMPODM)

corrplot(cor(d))

plot(final_data$EDAD, final_data$TIEMPODM, xlab="Edad", ylab="DM")

x_tab <- CrossTable(final_data$SEXO, final_data$ECIVIL,
                    prop.c=FALSE, prop.chisq=FALSE, prop.t=FALSE)

boxplot(TALLA ~ SEXO, data = final_data)

normalize_fun <-  function(x){
  y <- ( x - min(x) ) / (  max(x) - min(x))
  return (y)
}

normalize_fun(final_data$TIEMPODM)

qqnorm(final_data$TIEMPODM)

attach(final_data)
opar <- par(no.readonly=TRUE)
par(mfrow=c(2,2))
# plot(EDAD, TIEMPODM, type="b", lty=3, lwd=3, pch=15, cex=2)
plot(EDAD, TIEMPODM, cex=2)
abline(lm(EDAD~TIEMPODM))
title("Regression of EDAD  on TIEMPODM ")
hist(final_data$TIEMPODM, main = "TIEMPO DM", xlab = "DM")
boxplot(final_data$TIEMPODM)
par(opar)
detach(final_data)

hist(final_data$TIEMPODM, main = "TIEMPO DM", xlab = "DM")
plot(density(final_data$TIEMPODM))

boxplot(EDAD ~ TIEMPODM, data=final_data,
        main="Car Mileage Data",
        xlab="TIEMPODM",
        ylab="EDAD")

describe (final_data)

# filter  slice  filter(data, sexo == F)
# slice slice(data, 1:20)
# arrange ordernar
# select select (data, nfila = fila)
# distinct
# mutate  nuevas variables
# transmute nuevo data frame
# summarise
# sample_n sample_frac


## Change to where you downloaded and unziped to...
setwd("~/Desktop/bggn213_08_rstats/")

## Exercise 1

read.delim("weight_chart.txt") -> weight.chart

plot(weight.chart$Age,
     weight.chart$Weight,
     type="b",
     pch=15,
     cex=1.5,
     lwd=2,
     ylim=c(2,10),
     ylab="Weight (kg)",
     xlab="Age (months)",
     main="Plot of weight vs age for human babies (50th percentile)"
     )

read.delim("feature_counts.txt") -> feature.counts

par(mar=c(5,13,5,5))
barplot(feature.counts$Count,
        names.arg = feature.counts$Feature,
        horiz = TRUE,
        las=1)

hist(c(rnorm(10000),rnorm(10000)+4),breaks=50)

## Exercise 2
dev.off()
par(mar=c(5,9,5,5))
read.delim("male_female_counts.txt") -> male.female.counts
barplot(male.female.counts$Count, names.arg = male.female.counts$Sample ,col=c("blue","red"),horiz=TRUE,las=1)

read.delim("up_down_expression.txt") -> up.down.expression
palette(c("red","grey","blue"))
plot(up.down.expression$Condition1,
     up.down.expression$Condition2,
     col=up.down.expression$State,
     pch=19,
     cex=0.8,
     xlab="Condition1",
     ylab="Condition2")

read.delim("expression_methylation.txt") -> expression.methylation
range(expression.methylation$expression) -> expression.range
library(gplots)
colorRampPalette(c("grey","red"))(101) -> expression.palette

map.colours <- function (value,high.low,palette) {
  proportion <- ((value-high.low[1])/(high.low[2]-high.low[1]))
  index <- round ((length(palette)-1)*proportion)+1
  return (palette[index])
}

plot(expression.methylation$promoter.meth,
     expression.methylation$gene.meth,
     col=map.colours(expression.methylation$expression,expression.range,expression.palette),
     pch=19,
     cex=0.6,
     xlab="Promoter methylation (%)",
     ylab="Gene Body methylation (%)",
     main="Relationship between gene body and promoter meth.\nColoured by gene expression"
     )

## Exercise 3

read.delim("chromosome_position_data.txt") -> chromosome.position.data
range(chromosome.position.data[,2:4]) -> chr.pos.range

library(RColorBrewer)
brewer.pal(3,"Set1") -> chr.colours

plot(chromosome.position.data$Position,
     chromosome.position.data$WT,
     col=chr.colours[1],
     type="l",
     lwd=2,
     ylim=chr.pos.range,
     xlab="Chr Position",
     ylab="Count")

lines(chromosome.position.data$Position,
      chromosome.position.data$Mut1,
      col=chr.colours[2],
      lwd=2)

lines(chromosome.position.data$Position,
      chromosome.position.data$Mut2,
      col=chr.colours[3],
      lwd=2)

legend("topleft",colnames(chromosome.position.data)[2:4],fill=chr.colours)

read.delim("brain_bodyweight.txt",row.names=1) -> brain.body

plot(brain.body$Bodyweight,
     brain.body$Brainweight,
     pch=19,
     xlim=range(brain.body$Bodyweight)*1.1,
     ylim=range(brain.body$Brainweight)*1.1)

arrows(brain.body$Bodyweight,
       brain.body$Brainweight,
       brain.body$Bodyweight+brain.body$Bodyweight.SEM,
       brain.body$Brainweight,
       col="darkgrey",
       angle=90,
       length=0.05)

arrows(brain.body$Bodyweight,
       brain.body$Brainweight,
       brain.body$Bodyweight-brain.body$Bodyweight.SEM,
       brain.body$Brainweight,
       col="darkgrey",
       angle=90,
       length=0.05)

arrows(brain.body$Bodyweight,
       brain.body$Brainweight,
       brain.body$Bodyweight,
       brain.body$Brainweight+brain.body$Brainweight.SEM,
       col="darkgrey",
       angle=90,
       length=0.05)

arrows(brain.body$Bodyweight,
       brain.body$Brainweight,
       brain.body$Bodyweight,
       brain.body$Brainweight-brain.body$Brainweight.SEM,
       col="darkgrey",
       angle=90,
       length=0.05)

text(rownames(brain.body),x=brain.body$Bodyweight,y=brain.body$Brainweight-0.1,cex=0.7)

read.delim("different_scales.txt") -> different.scales
dev.off()
par(mfrow=c(1,2))
plot(different.scales$Index,different.scales$Data1,type="l",xlab="Index",ylab="Data1",main="Data1")
plot(different.scales$Index,different.scales$Data2,type="l",xlab="Index",ylab="Data2",main="Data2")

dev.off();
par(mar=c(5,7,5,7))
plot(different.scales$Index,different.scales$Data1,type="l",xlab="Index",ylab="Data1",col="red")
par(new=TRUE)
plot(different.scales$Index,different.scales$Data2,type="l",xaxt="n",yaxt="n",col="blue",xlab="",ylab="")
axis(side=4)
mtext(4,text="Data2",line=3)


fileName <- "rounds.txt"
rounds <- as.numeric(readChar(fileName, file.info(fileName)$size))

x = 1.0
pi = 1.0

for (i in 2:(rounds + 2)){
  x = x * -1
  pi = pi + (x / (2 * i - 1))
}

pi = pi * 4

printf <- function(...) cat(sprintf(...))
printf("%.16f\n", pi)


# ggplot2

# 01 패키지 및 데이터 불러오기
rm(list=ls())
install.packages("ggplot2")
library(ggplot2)
search()

data(mtcars)
qplot(mtcars$wt, mtcars$mpg)

# 02 qplot
qplot(mtcars$wt, mtcars$mpg)

# 03 위와 같음
ggplot(mtcars, aes(x=wt, y=mpg)) +
  geom_point()

# 04 선그래프 만들기
# Data on the relation between temperature in degrees
# Celsius and vapor pressure of mercury in millimeters (of mercury).
?pressure
?qplot
pressure
qplot(temperature,
        pressure,
        data=pressure,
        geom="line"
      )

xlab <- c(1,2,3,45,66)
ylab <- c(20,30,40,50,60)
data_f <- data.frame(xlab, ylab)
qplot(xlab,
      ylab,
      data=data_f,
      geom="line"
)

# ggplot2
ggplot(pressure,
       aes(x=temperature, y=pressure)) +
      geom_line() +
      geom_point()

# 05 막대 그래프
# 데이터 셋 : mtcars
mtcars$cyl
qplot(factor(cyl), data=mtcars)
ggplot(mtcars, aes(x=factor(cyl))) +
  geom_bar()

# 06 히스토그램
# 데이터 셋 : mtcars
?hist
mtcars$mpg
hist(mtcars$mpg, breaks=10)

?qplot()
qplot(mpg, data=mtcars, binwidth=1)

ggplot(mtcars, aes(x=mpg)) +
        geom_histogram(binwidth=1)

# 07 Box Plot
# 데이터 셋 : mtcars
?boxplot
?ToothGrowth
str(mtcars)
ToothGrowth
boxplot(len~supp , data=ToothGrowth)

?qplot()
qplot(supp, len,
      data=ToothGrowth,
      geom="boxplot")

library(ggplot2)
ggplot(ToothGrowth, aes(x=supp, y=len)) +
       geom_boxplot()

# ggplot stat
# dataset : gcookbook
?gcookbook
?ggplot
# install.packages("gcookbook")
library(gcookbook)
ggplot(pg_mean, aes(x=group, y=weight)) +
  geom_bar(stat="identity")

# 색 넣기, 외곽선색(검정)
ggplot(pg_mean, aes(x=group, y=weight)) +
    geom_bar(stat="identity",
             fill="lightblue",
             colour="black")

# 이변량 변수 표시(1)
cabbage_exp
search()
ggplot(cabbage_exp,
       aes(x=Date, y=Weight, fill=Cultivar)) +
       geom_bar(stat="identity",position="dodge")

# 이변량 변수 표시(2-1) palette
ggplot(cabbage_exp,
       aes(x=Date, y=Weight, fill=Cultivar)) +
  geom_bar(stat="identity",position="dodge") +
  scale_fill_brewer(palette="Pastel1")

# 이변량 변수 표시(3) guides(fill=guide_legend(reverse=TRUE))
ggplot(cabbage_exp,
       aes(x=Date, y=Weight, fill=Cultivar)) +
  geom_bar(stat="identity") +
  guides(fill=guide_legend(reverse=TRUE))

# 이변량 변수 표시(2-2) 숫자 레이블 추가
ggplot(cabbage_exp,
      aes(x=interaction(Date, Cultivar), y=Weight)) +
      geom_bar(stat="identity") +
      geom_text(aes(label=Weight), vjust=1.5, colour="white")

ggplot(cabbage_exp,
       aes(x=interaction(Date, Cultivar), y=Weight)) +
      geom_bar(stat="identity") +
      geom_text(aes(label=Weight), vjust=-0.2)


# 4. faza: Napredna analiza podatkov

obrisi = function(podatki, hc = TRUE, od = 2, do = NULL) {
  n = nrow(podatki)
  if (is.null(do)) {
    do = n - 1
  }

  razdalje = dist(podatki)

  k.obrisi = tibble()
  for (k in od:do) {
    if (hc) {
      o.k = hclust(razdalje) %>%
        cutree(k) %>%
        silhouette(razdalje)
    } else {
      set.seed(42) # zato, da so rezultati ponovljivi
      o.k = kmeans(podatki, k)$cluster %>%
        silhouette(razdalje)
    }
    k.obrisi = k.obrisi %>% bind_rows(
      tibble(
        k = rep(k, n),
        obrisi = o.k[, "sil_width"]
      )
    )
  }
  k.obrisi$k = as.ordered(k.obrisi$k)

  k.obrisi
}

obrisi.povprecje = function(k.obrisi) {
  k.obrisi.povprecje = k.obrisi %>%
    group_by(k) %>%
    summarize(obrisi = mean(obrisi))
}

obrisi.k = function(k.obrisi) {
  obrisi.povprecje(k.obrisi) %>%
    filter(obrisi == max(obrisi)) %>%
    summarize(k = min(k)) %>%
    unlist() %>%
    as.character() %>%
    as.integer()
}

diagram.obrisi = function(k.obrisi) {
  ggplot() +
    geom_boxplot(
      data = k.obrisi,
      mapping = aes(x = k, y = obrisi)
    ) +
    geom_point(
      data = obrisi.povprecje(k.obrisi),
      mapping = aes(x = k, y = obrisi),
      color = "red"
    ) +
    geom_line(
      data = obrisi.povprecje(k.obrisi),
      mapping = aes(x = as.integer(k), y = obrisi),
      color = "red"
    ) +
    geom_point(
      data = obrisi.povprecje(k.obrisi) %>%
        filter(obrisi == max(obrisi)) %>%
        filter(k == min(k)),
      mapping = aes(x = k, y = obrisi),
      color = "blue"
    ) +
    xlab("število skupin (k)") +
    ylab("obrisi (povprečje obrisov)") +
    ggtitle(paste("Maksimalno povprečje obrisov pri k =", obrisi.k(k.obrisi))) +
    theme_classic()
}

nakupi = tabela2 %>% dplyr::select(
  Year, Country, Stopnja, Koliko_vseh_nakupov_je_opravila_ta_skupina
) %>%
  filter(
    Year == 2019
  ) %>%
  pivot_wider(
    names_from = Stopnja,
    values_from = Koliko_vseh_nakupov_je_opravila_ta_skupina
  ) %>%
  dplyr::select(-Year)
nakupi[5, 1] = 'Germany'
nakupi[38, 1] = 'Kosovo'

#dendrogram, hierarhično razvrščanje v skupine
drzave = nakupi[, 1] %>% unlist()
razdalje = nakupi[, -1] %>% dist()
dendrogram = razdalje %>% hclust(method = "ward.D")
#dendrogramcek <- plot(
#  dendrogram,
#  labels = drzave,
#  ylab = "višina",
#  main = NULL
#)
#Zgornjo kodo, ki nariše dendrogram, sem zakomentirala, saj se mi je dendrogramcek kljub temu, da sem ga shranila
#pod spremenljivko in ga ne poklicala v poročilu, še zmeraj prikazoval.

hc.kolena = function(dendrogram, od = 1, do = NULL, eps = 0.5) {
  # število primerov in nastavitev parametra do
  n = length(dendrogram$height) + 1
  if (is.null(do)) {
    do = n - 1
  }
  # k.visina je tabela s štirimi stolpci
  # (1) k, število skupin
  # (2) višina združevanja
  # (3) sprememba višine pri združevanju
  # (4) koleno: ali je točka koleno?
  k.visina = tibble(
    k = as.ordered(od:do),
    visina = dendrogram$height[do:od]
  ) %>%
    # sprememba višine
    mutate(
      dvisina = visina - lag(visina)
    ) %>%
    # ali se je intenziteta spremembe dovolj spremenila?
    mutate(
      koleno = lead(dvisina) - dvisina > eps
    )
  k.visina
}

# iz tabele k.visina vrne seznam vrednosti k,
# pri katerih opazujemo koleno
hc.kolena.k = function(k.visina) {
  k.visina %>%
    filter(koleno) %>%
    dplyr::select(k) %>%
    unlist() %>%
    as.character() %>%
    as.integer()
}

# izračunamo tabelo s koleni za dendrogram
r = hc.kolena(dendrogram)

# narišemo diagram višin združevanja
diagram.kolena = function(k.visina) {
  k.visina %>% ggplot() +
    geom_point(
      mapping = aes(x = k, y = visina),
      color = "red"
    ) +
    geom_line(
      mapping = aes(x = as.integer(k), y = visina),
      color = "red"
    ) +
    geom_point(
      data = k.visina %>% filter(koleno),
      mapping = aes(x = k, y = visina),
      color = "blue", size = 2
    ) +
    ggtitle(paste("Kolena:", paste(hc.kolena.k(k.visina), collapse = ", "))) +
    xlab("število skupin (k)") +
    ylab("razdalja pri združevanju skupin") +
    theme_classic()
}
diagram.kolena(r)

diagram.skupine = function(podatki, oznake, skupine, k) {
  podatki = podatki %>%
    bind_cols(skupine) %>%
    dplyr::rename(skupina = ...4)

  d = podatki %>%
    ggplot(
      mapping = aes(
        x = x, y = y, color = skupina
      )
    ) +
    geom_point() +
    geom_label(label = oznake, size = 2) +
    scale_color_hue() +
    theme_classic()

  for (i in 1:k) {
    d = d + geom_encircle(
      data = podatki %>%
        filter(skupina == i)
    )
  }
  d
}

#k-ti voditelji

b <- transform(nakupi, No_or_low= as.numeric(unlist(nakupi[,2])),
          Med = as.numeric(unlist(nakupi[,3])),
          High = as.numeric(unlist(nakupi[,4])),
          Students = as.numeric(unlist(nakupi[,5])))%>% dplyr::select(Students, No_or_low, Med, High)
skupine = b[, -1] %>%
  kmeans(centers = 3) %>%
  getElement("cluster") %>%
  as.ordered()

print(skupine)
r.hc = nakupi[, -1] %>% obrisi(hc = TRUE)
r.km = nakupi[, -1] %>% obrisi(hc = FALSE)

diagram.obrisi(r.hc)
diagram.obrisi(r.km)

#Optimalno število skupin je torej 2 ali 4/5.

drzave.x.y =
  as_tibble(razdalje %>% cmdscale(k = 2)) %>%
  bind_cols(drzave) %>%
  dplyr::select(drzava = ...3, x = V1, y = V2)

k = obrisi.k(r.hc)
skupine = nakupi[, -1] %>%
  dist() %>%
  hclust(method = "ward.D") %>%
  cutree(k = k) %>%
  as.ordered()
diagram.skupine(drzave.x.y, drzave.x.y$drzava, skupine, k)

k = obrisi.k(r.km)
set.seed(42) # ne pozabimo na ponovljivost rezultatov
skupine = nakupi[, -1] %>%
  kmeans(centers = k) %>%
  getElement("cluster") %>%
  as.ordered()
diagram.skupine(drzave.x.y, drzave.x.y$drzava, skupine, k)

set.seed(42)
skupine = nakupi[, -1] %>%
  kmeans(centers = 4) %>%
  getElement("cluster") %>%
  as.ordered()
skup <- diagram.skupine(drzave.x.y, drzave.x.y$drzava, skupine, 2)

download.file(url='https://kt.ijs.si/~ljupco/lectures/appr/zemljevidi/svet/TM_WORLD_BORDERS-0.3.shp',
              destfile='TM_WORLD_BORDERS-0.3.shp', method='curl')
download.file(url='https://kt.ijs.si/~ljupco/lectures/appr/zemljevidi/svet/TM_WORLD_BORDERS-0.3.dbf',
              destfile='TM_WORLD_BORDERS-0.3.dbf', method='curl')
download.file(url='https://kt.ijs.si/~ljupco/lectures/appr/zemljevidi/svet/TM_WORLD_BORDERS-0.3.shx',
              destfile='TM_WORLD_BORDERS-0.3.shx', method='curl')
svet.sp <- readOGR(getwd(), "TM_WORLD_BORDERS-0.3")
svet.sp = gBuffer(svet.sp, byid = TRUE, width = 0)

svet.centroidi = read_csv("podatki/drzave-centroidi.csv")
evropske.drzave = tibble(
  drzava = c(
    "Albania", "Andorra", "Armenia",
    "Austria", "Azerbaijan", "Belarus",
    "Belgium", "Bosnia and Herzegovina",
    "Bulgaria", "Croatia", "Cyprus",
    "Czechia", "Denmark", "Estonia",
    "Finland", "France", "Georgia",
    "Germany", "Greece", "Hungary",
    "Iceland", "Ireland", "Italy",
    "Kazakhstan", "Latvia",
    "Liechtenstein", "Lithuania",
    "Luxembourg", "Malta", "Moldova",
    "Monaco", "Montenegro",
    "Netherlands", "North Macedonia",
    "Norway", "Poland", "Portugal",
    "Romania", "Russia", "San Marino",
    "Serbia", "Slovakia", "Slovenia",
    "Spain", "Sweden", "Switzerland",
    "Turkey", "Ukraine", "United Kingdom",
    "Holy See (Vatican City)"
  )
)

evropa.izsek = as(extent(-25, 60, 30, 75), "SpatialPolygons")
sp::proj4string(evropa.izsek) <- sp::proj4string(svet.sp)

evropske.drzave = tibble(
  drzava = c(
    "Albania", "Andorra", "Armenia",
    "Austria", "Azerbaijan", "Belarus",
    "Belgium", "Bosnia and Herzegovina",
    "Bulgaria", "Croatia", "Cyprus",
    "Czechia", "Denmark", "Estonia",
    "Finland", "France", "Georgia",
    "Germany", "Greece", "Hungary",
    "Iceland", "Ireland", "Italy",
    "Kazakhstan", "Latvia",
    "Liechtenstein", "Lithuania",
    "Luxembourg", "Malta", "Moldova",
    "Monaco", "Montenegro",
    "Netherlands", "North Macedonia",
    "Norway", "Poland", "Portugal",
    "Romania", "Russia", "San Marino",
    "Serbia", "Slovakia", "Slovenia",
    "Spain", "Sweden", "Switzerland",
    "Turkey", "Ukraine", "United Kingdom",
    "Holy See (Vatican City)"
  )
)

# Evropa se po zemljepisni dolžini razteza
# od -25 do 60, po širini pa od 30 do 75
evropa.izsek = as(extent(-25, 60, 30, 75), "SpatialPolygons")
sp::proj4string(evropa.izsek) <- sp::proj4string(svet.sp)
colnames(evropske.drzave)[1] <- "NAME"
evropa.poligoni = svet.sp %>% crop(evropa.izsek) %>% fortify() %>% tibble() %>%
left_join(
  evropske.drzave,
  by = "NAME"
)
colnames(svet.centroidi)[1] <- "NAME"
evropa.centroidi = evropske.drzave %>%
  left_join(
    svet.centroidi,
    by = "NAME"
  )

colnames(evropa.poligoni)[12] <- "drzava"
colnames(evropa.centroidi)[1] <- "drzava"

prostorski.diagram.skupine = function(drzave, skupine, k) {
  drzave %>%
    bind_cols(skupine) %>%
    dplyr::select(drzava = ...1, skupina = ...2) %>%
    left_join(
      evropa.poligoni,
      by = "drzava"
    ) %>%
    ggplot() +
    geom_polygon(
      mapping = aes(long, lat, group = group, fill = skupina),
      color = "grey"
    ) +
    scale_fill_brewer() +
    coord_map() +
    xlim(-25, 50) +
    theme_classic() +
    theme(
      axis.line = element_blank(),
      axis.ticks = element_blank(),
      axis.text = element_blank(),
      axis.title = element_blank()
    )
}

set.seed(42)
skupine = nakupi[, -1] %>%
  kmeans(centers = 2) %>%
  getElement("cluster") %>%
  as.ordered()

z1 <- prostorski.diagram.skupine(drzave, skupine, 2)

k = dendrogram %>%
  hc.kolena %>%
  hc.kolena.k() %>%
  getElement(1)

skupine = dendrogram %>%
  cutree(k = 4) %>%
  as.ordered()

z2<- prostorski.diagram.skupine(drzave, skupine, k)

podatki.ucni <- tabela1 %>%
  filter(
    Year == 2019
  ) %>%
  dplyr::select(-Year, - Area)
podatki.ucni <- podatki.ucni[-c(2, 4, 6, 8, 10, 12, 14, 16, 18, 20, 22, 24, 26, 28, 30, 32, 34, 36, 38, 40, 42, 44, 46, 48, 50, 52, 54, 56, 58, 60, 62, 64, 66, 68), ]

podatki.ucni <- podatki.ucni[(-c(32, 33, 34)),]
g <- ggplot(podatki.ucni, aes(x=BDPpc, y=Value)) + geom_point()
g + geom_smooth(method="lm")

lin <- lm(data=podatki.ucni, Value ~ BDPpc + Education)
lin
napovedi <- predict(lin)

kv <- lm(data=podatki.ucni, Value ~ Education + I(BDPpc^2))

mls <- loess(data=podatki.ucni, Value ~ BDPpc + Education)

sapply(list(lin, kv, mls), function(x) mean((x$residuals^2)))

podatki.ucni <- transform(podatki.ucni, Education = as.numeric(as.character(Education)))
k <- 5
formula <- Value ~ BDPpc

napaka.cv <- function(podatki, k, formula) {
  n <- nrow(podatki)
  r <- sample(1:n)

  razrez <- cut(1:n, k, labels = FALSE)

  razbitje <- split(r, razrez)

  pp.napovedi = rep(0, n)
  for (i in 1:length(razbitje)) {
    #Naučimo se modela na množici S/Si
    model = podatki[ -razbitje[[i]], ] %>% lm(formula = formula)
    #Naučen model uporabimo za napovedi na Si
    pp.napovedi[ razbitje[[i]] ] = predict(object = model, newdata = podatki[ razbitje [[i]], ] )

  }

  #model so učni podatki in ostalo ( razbitje[[i]]) so testni podatki.

  napaka <- mean((pp.napovedi - podatki$Value)^2)
  return(napaka)
}
napaka.cv(podatki.ucni, 5, formula)

formule <- c(Value ~ BDPpc,
             Value ~ BDPpc + I(BDPpc^2),
             Value ~ BDPpc + I(BDPpc^2) + I(BDPpc^3),
             Value ~ BDPpc + I(BDPpc^2) + I(BDPpc^3) + I(BDPpc^4),
             Value ~ BDPpc + I(BDPpc^2) + I(BDPpc^3) + I(BDPpc^4) +I(BDPpc^5))
napake <- rep(0, 5)
for (i in 1:5){
  formula <- formule[[i]]
  napaka <- napaka.cv(podatki.ucni, 5, formula)
  napake[i] <- napaka
}
which.min(napake)
lin.model <- lm(data = podatki.ucni, formula = Value ~ BDPpc + I(BDPpc^2))

napaka_regresije = function(podatki, model) {
  podatki %>%
    bind_cols(Value.hat = predict(model, podatki)) %>%
    mutate(
      izguba = (Value - Value.hat) ^ 2
    ) %>%
    dplyr::select(izguba) %>%
    unlist() %>%
    mean()
}

library(ranger)
library(janitor)
p.ucni <- janitor::clean_names(podatki.ucni)
set.seed(42)

ucenje = function(podatki, formula, algoritem) {
  switch(
    algoritem,
    lin.reg = lm(formula, data = podatki),
    ng = ranger(formula, data = podatki)
  )
}

napovedi = function(podatki, model, algoritem) {
  switch(
    algoritem,
    lin.reg = predict(model, podatki),
    ng = predict(model, podatki)$predictions
  )
}

napaka_regresije = function(podatki, model, algoritem) {
  podatki %>%
    bind_cols(value.hat = napovedi(podatki, model, algoritem)) %>%
    mutate(
      izguba = (value - value.hat) ^ 2
    ) %>%
    dplyr::select(izguba) %>%
    unlist() %>%
    mean()
}

napaka_razvrscanja = function(podatki, model, algoritem) {
  podatki %>%
    bind_cols(value.hat = napovedi(podatki, model, algoritem)) %>%
    mutate(
      izguba = (value != value.hat)
    ) %>%
    dplyr::select(izguba) %>%
    unlist() %>%
    mean()
}

lin.model = p.ucni %>% ucenje(value ~ bd_ppc, "lin.reg")
p.ucni %>% napaka_regresije(lin.model, "lin.reg")

set.seed(42)
ng.reg.model = p.ucni %>% ucenje(value ~ bd_ppc, "ng")
print(p.ucni %>% napaka_regresije(ng.reg.model, "ng"))

k <- 5
formula2 <- value ~ bd_ppc

napaka.cv2 <- function(podatki, k, formula) {
  n <- nrow(podatki)
  r <- sample(1:n)

  razrez <- cut(1:n, k, labels = FALSE)

  razbitje <- split(r, razrez)

  pp.napovedi = rep(0, n)
  for (i in 1:length(razbitje)) {
    #Naučimo se modela na množici S/Si
    model = podatki[ -razbitje[[i]], ] %>% ranger(formula = formula)
    #Naučen model uporabimo za napovedi na Si
    pp.napovedi[ razbitje[[i]] ] = predict(object = model, data = podatki[ razbitje [[i]], ])$predictions

  }

  #model so učni podatki in ostalo ( razbitje[[i]]) so testni podatki.

  napaka <- mean((pp.napovedi - podatki$value)^2)
  return(napaka)
}
napaka.cv(p.ucni, 5, formula2)

formule <- c(Value ~ BDPpc,
             Value ~ BDPpc + I(BDPpc^2),
             Value ~ BDPpc + I(BDPpc^2) + I(BDPpc^3),
             Value ~ BDPpc + I(BDPpc^2) + I(BDPpc^3) + I(BDPpc^4),
             Value ~ BDPpc + I(BDPpc^2) + I(BDPpc^3) + I(BDPpc^4) +I(BDPpc^5))
napake <- rep(0, 5)
for (i in 1:5){
  formula <- formule[[i]]
  napaka <- napaka.cv(podatki.ucni, 5, formula)
  napake[i] <- napaka
}
which.min(napake)
lin.model <- lm(data = podatki.ucni, formula = Value ~ BDPpc + I(BDPpc^2))

library(iml)

# Pripravimo le napovedne spremenljivke,
# kot jih rabi funkcija Predictor$new

X = p.ucni %>% dplyr::select(bd_ppc, education)

# Funkciji Predictor$new moramo povedati
# kako napovedujemo z modelom naključnih gozdov

pfun = function(model, newdata) {
  predict(model, data = newdata, predict.all = FALSE)$predictions
}

# pripravimo najprej objekt razreda Prediktor
# prvi argument funkcije je model,
# drugi in tretji so podatki o napovednih
# in ciljni spremenljivki,
# zadnji pa funkcija za napovedovanje

reg.pred = Predictor$new(
  ng.reg.model,
  data = X, y = p.ucni$value,
  predict.fun = pfun
)

# na koncu uporabimo funkcijo FeatureImp$new
reg.moci = FeatureImp$new(reg.pred, loss = "mse")

plot(reg.moci)

slo <- tabela1 %>% filter(Country == "Slovenia")
slo <- slo[-c(2, 4, 6, 8, 10, 12, 14, 16, 18, 20, 22, 24, 26, 28, 30, 32),]
slo <- slo[-c(1, 2),]

CAC <- slo[,4]
CACs <- slo[,c(1,4)]
CACs %>% ggplot() +
  geom_line(
    mapping = aes(x = Year, y = Value),
    color = "pink"
  )
library(ranger)
Lag <- function(x, n){
  (c(rep(NA, n), x)[1 : length(x)] )
}
naredi.df <- function(x){data.frame(Value = x,
                                    Value1 = Lag(x, 1),
                                    Value2 = Lag(x, 2) ,
                                    Value3 = Lag(x, 3),
                                    Value4 = Lag(x, 4)
)
}
df <- naredi.df(CAC$Value)
model.bi = ranger(Value ~ Value1 + Value2 + Value3 + Value4, data=df %>% drop_na())
lllll <- nrow(df)
for (i in 1:5){
  df <- naredi.df(c(df$Value, NA))
  napoved = predict(model.bi,  data = df[lllll + i, ] )$predictions
  df[lllll+i, 1] = napoved
}
napovedi = df[c(15, 16, 17, 18, 19), 1]
CACs2 <- CACs
CACs2[c(15, 16, 17, 18, 19),2] = napovedi
CACs2[c(15, 16, 17, 18, 19),1] = c(2020, 2021, 2022, 2023, 2024)

nap <- ggplot(CACs2) + geom_point(aes(x = Year, y = Value, colour = Year > 2019)) +
  scale_colour_manual(name = 'Napovedi', values = setNames(c('magenta','blue'),c(T, F))) +
  xlab('Leto') + ylab('Odstotek ljudi, ki spletno nakupuje')


## Dati

mi.1 <- 1.02
var.1 <- 2.17

mi.2 <- 1.85
var.2 <- 4.65

## Svolgimento

y.negativa <- pnorm(0, mi.2, sqrt(var.2))
x.negativa <- pnorm(0, mi.1, sqrt(var.1))

pr.1 <- 1 - (x.negativa*y.negativa)
pr.2 <- (1 - x.negativa)/pr.1

print(pr.1)
print(pr.2)


b <- read.csv('Batting.csv') # Batting

# Batting Average
b$BA <- b$H / b$AB

# On-base percentage
b$OBP <- (b$H + b$BB + b$BHP) / (b$AB + b$BB + b$HBP + b$SF)

# Calculate singles
b$X1B <- b$H - b$X2B - b$X3B - b$HR

# Slugging Average
b$SLG <- ((1 * b$X1B) + (2 * b$X2B) + (3 * b$X3B) + (4 * b$HR)) / b$AB

# Filter away before the year 1985
b <- subset(b, yearID >= 1985)

s <- read.csv('Salaries.csv') # Salaries

# Merged datasets
m <- merge(b, s, by = c('playerID', 'yearID'))

# Get the lost players, all occcursions
lost_players <- subset(m, playerID %in% c('giambja01', 'damonjo01', 'saenzol01'))
lost_players <- subset(lost_players, yearID==2001)
lost_players <- lost_players[, c('playerID', 'H', 'X2B', 'X3B', 'HR', 'OBP', 'SLG', 'BA', 'AB')]
# Sort out players available
m <- subset(m, yearID == 2001)
# Visualize the persons
ggplot(m, aes(x = OBP, y = salary)) + geom_point()
# Sorting away people who only hit once & remove AB >= 450
m <- subset(m, salary < 8000000 & OBP > 0)
m <- subset(m, AB >= 450)

library(dplyr) # Structurize it better
options <- head(arrange(m, desc(OBP)), 10)
options[, c('playerID','AB', 'salary', 'OBP')]


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

# Create star_wars_matrix
star_wars_matrix <- rbind(new_hope, empire_strikes, return_jedi)
print(star_wars_matrix)

# Name the columns and rows of star_wars_matrix
colnames(star_wars_matrix) <- c("US","non-US")
rownames(star_wars_matrix) <- c("A New Hope","The Empire Strikes Back","Return of the Jedi")
print(star_wars_matrix)

# Calculate the worldwide box office: worldwide_vector
worldwide_vector <- rowSums(star_wars_matrix)
print(worldwide_vector)

# Bind the new variable worldwide_vector as a column to star_wars_matrix: star_wars_ext
star_wars_ext <- cbind(star_wars_matrix, worldwide_vector)
print(star_wars_ext)


setwd('E:teaching/2015_acg5075_r/introR')

# read csv file with columns: month,orders,costs
myCosts = read.csv("chapter15/costdata.csv")
myCosts
#       description fixed variable
# 1 Plant materials     0      0.5
# 2             Pot     0      0.3
# 3           Labor  8000      0.7
# 4       Utilities  9000      0.0
# 5            Rent  7500      0.0
# 6     Other costs  2500      0.0

# in chapter 14 example we transformed it into a matrix with as.matrix
# we don't need to do that here (matrix requires all columns to be of
# same type, which is not the case as description is text and costs are numbers)

# without setwd, the read would be:
# myData = read.csv("E:teaching/2015_acg5075_r/introR/chapter15/costdata.csv")

#break-even point: sales = expenses, or fixed coss = contribution margin
sales <- 15 # sales price $15 per plant

#we can get to a column name with $
myCosts$variable
#[1] 0.5 0.3 0.7 0.0 0.0 0.0
myCosts$fixed
#[1]    0    0 8000 9000 7500 2500

#Contribution margin: sales - total variable costs per unit
CM <- sales - sum(myCosts$variable)
CM
#[1] 13.5

#total fixed costs
fixed <- sum(myCosts$fixed)
fixed
#[1] 27000

#break-even #units
beUnits <- fixed/CM
beUnits
#[1] 2000

#break even sales ($) is breakEven units x $15 per unit
cat("Break even sales in $ ", beUnits * sales)
#Break even sales in $  30000

#profit target, $10,000 after tax, is $10,000 / 0.65 if tax reate is 35%
unitsForTarget <- (fixed / 0.65) / CM
unitsForTarget
#[1] 3076.923


#Import library
library(prodlim)

pseudo<-function(data, evaltime){
#      The Aalen-Johansen estimator is used to estimate the absolute risk of the competing causes, i.e., the cumulative incidence functions.
#      Pseudo values can be estimated at a pre-specified grid of time points. We consider 12 and 60 months as evaluation times and 2 causes of the event in our paper.
#      It can be generalized for more than 2 evaluation times and more than 2 causes of the event.

#     Arguments:
#       data: A competing risk dataframe containing survival time and event status, which will be used to estimate pseudo values for CIF.
#       evaltime: Evaluation times

#     Returns:
#       A dataframe of pseudo values for all subjects for all causes at the evaluation time points.

    # Extract time and event status from the competing risk data
    time<-data[, 'time']
    status<-data[,'status']

    # Call function for estimating CIF from right censored data using the Aalen-Johansen estimator
    f=prodlim(Hist(time, status)~1)

    #Compute pseudo values for cause 1
    pseudo_c1<-jackknife(f, times=evaltime, cause=1)   #times: Time points at which to compute pseudo values
                                                       #cause: Cause of failure

    #Compute pseudo values for cause 2
    pseudo_c2<-jackknife(f, times=evaltime, cause=2)

    # Each row of pseudo values for cause2 are arranged just after each row of pseudo values for cause1 so that for each
    # observation, we get an array with shape = (No. of events, No. of evaluation times)
    pseudo_value<-rbind(pseudo_c1[1,], pseudo_c2[1,])
    for (i in 2:length(time)){
         pseudo_value<-rbind(pseudo_value, pseudo_c1[i,], pseudo_c2[i,])
      }
      return(pseudo_value)

}


#' Obtain 2x2 contingency table from marginal parameters and odds ratio
#'
#' Columns are the case and control frequencies
#' Rows are the frequencies for allele 1 and allele 2
#'
#' @param af Allele frequency of effect allele
#' @param prop Proportion of cases
#' @param odds_ratio Odds ratio
#' @param eps tolerance. Default = 1e-15
#'
#' @export
#' @return 2x2 contingency table as matrix
contingency <- function(af, prop, odds_ratio, eps=1e-15)
{
	a <- odds_ratio-1
	b <- (af+prop)*(1-odds_ratio)-1
	c_ <- odds_ratio*af*prop

	if (abs(a) < eps)
	{
		z <- -c_ / b
	} else {
		d <- b^2 - 4*a*c_
		if (d < eps*eps)
		{
			s <- 0
		} else {
			s <- c(-1,1)
		}
		z <- (-b + s*sqrt(max(0, d))) / (2*a)
	}
	y <- vapply(z, function(a) zapsmall(matrix(c(a, prop-a, af-a, 1+a-af-prop), 2, 2)), matrix(0.0, 2, 2))
	i <- apply(y, 3, function(u) all(u >= 0))
	return(y[,,i])
}

#' Estimate allele frequency from SNP
#'
#' @param g Vector of 0/1/2
#'
#' @export
#' @return Allele frequency
allele_frequency <- function(g)
{
	(sum(g == 1) + 2 * sum(g == 2)) / (2 * sum(!is.na(g)))
}

#' Estimate the allele frequency in population from case/control summary data
#'
#' @param af Effect allele frequency (or MAF)
#' @param prop Proportion of samples that are cases
#' @param odds_ratio Odds ratio
#' @param prevalence Population disease prevalence
#'
#' @export
#' @return Population allele frequency
get_population_allele_frequency <- function(af, prop, odds_ratio, prevalence)
{
	co <- contingency(af, prop, odds_ratio)
	af_controls <- co[1,2] / (co[1,2] + co[2,2])
	af_cases <- co[1,1] / (co[1,1] + co[2,1])
	af <- af_controls * (1 - prevalence) + af_cases * prevalence
	return(af)
}

#' Estimate proportion of variance of liability explained by SNP in general population
#'
#' This uses equation 10 in Genetic Epidemiology 36 : 214–224 (2012)
#'
#' @param b Log odds ratio
#' @param af allele frequency
#' @param ncase Number of cases
#' @param ncontrol number of controls
#' @param prevalence prevalence
#' @param model Is the effect size estiamted in "logit" (default) or "probit" model
#'
#' @export
#' @return Rsq
lor_to_rsq <- function(b, af, ncase, ncontrol, prevalence, model="logit")
{
	if(model == "logit")
	{
		ve <- pi^2/3
	} else if(model == "probit") {
		ve <- 1
	} else {
		stop("Model must be probit or logit")
	}
	af <- get_population_allele_frequency(af, ncase / (ncase + ncontrol), exp(b), prevalence)
	vg <- b^2 * af * (1-af)
	return(vg / (vg + ve) / 0.58)
}


#' Function that creates a sinusoidal Sea Surface Temperature (SST) curve
#' from a list of parameters
#'
#' Takes the specified parameters for amplitude, period, phase and average value
#' as well as the number of years specified and the time interval. It then
#' creates a sinusoid based on the boundary conditions. Used as intermediate
#' step during iterative modeling.
#'
#' @param T_par List of four parameters describing (in order) amplitude
#' (\code{T_amp}; in degrees C), period (\code{T_per}; in days), phase
#' (\code{T_pha} in day of the year) and average temperature (\code{T_av};
#' in degrees C)
#' @param years Length of the preferred sinusoid in number of years (defaults
#' to 1)
#' @param t_int Time interval of sinusoidal record (in days)
#' @return A matrix containing columns for time (in days) and SST (in degrees C)
#' @examples
#' # Set parameters
#' T_amp <- 20
#' T_per <- 365
#' T_pha <- 150
#' T_av <- 15
#' T_par <- c(T_amp, T_per, T_pha, T_av)
#' SST <- temperature_curve(T_par, 1, 1) # Run the function
#' @export
temperature_curve <- function(T_par, # Function to create temperature as function of time based on sinusoidal parameters
    years = 1, # Default number of years of the record = 1
    t_int = 1 #  Default time interval = 1 day
    ){

    T_amp <- T_par[1] # Seasonal SST range (degr. C)
    T_per <- T_par[2] # Period of SST seasonality (days)
    T_pha <- T_par[3] # Timing of peak in SST sinusoid (day of the year)
    T_av <- T_par[4] # Annual average SST (degr. C)

    t <- seq(0, years * T_per, t_int) # Define time axis based on the number of days in a year and the time interval. Model multiple years (default = 3) to accommodate changes in growth rate over lifetime.

    SST <- T_av + T_amp/2 * sin((2 * pi * (t - T_pha + T_per/4)) / T_per) # Create SST sinusoid based on parameters and time vector

    # Collate results and export
    res <- cbind(t, SST)
    return(res)
}


args = commandArgs(trailingOnly=TRUE)
if (length(args)==0) {
  stop("At least one argument must be supplied (input file).n", call.=FALSE)

inputfile<-"args[1]"
WD<-getwd()
setwd (WD)
outputfile<-"all_lim_167"
library(calibrate)
data1<- read.table (inputfile, header = TRUE)
attach (data1)
data2 <- as.dist(data1)  #this gives a triangular matrix dist 2 is triangular matrix
output1<-cmdscale(data2, k = 2, eig = FALSE, add = FALSE, x.ret = FALSE)

pdf (file =paste(outputfile,"_mds.pdf", sep=""), width =10, height = 10, pointsize =12)
plot (output1[,1], output1[,2], col = "aquamarine4", pch = 20, asp = 1, xlab="Component1", ylab="Component2", main= paste("MDS off:",inputfile))
text(output1[,1], output1[,2],  rownames(output1), cex = 0.8, col = "black")
dev.off()
q()
N


longmult <- function(xstr, ystr)
{
   #get the number described in each string
   getnumeric <- function(xstr) as.numeric(unlist(strsplit(xstr, "")))

   x <- getnumeric(xstr)
   y <- getnumeric(ystr)

   #multiply each pair of digits together
   mat <- apply(x %o% y, 1, as.character)

   #loop over columns, then rows, adding zeroes to end of each number in the matrix to get the correct positioning
   ncols <- ncol(mat)
   cols <- seq_len(ncols)
   for(j in cols)
   {
      zeroes <- paste(rep("0", ncols-j), collapse="")
      mat[,j] <- paste(mat[,j], zeroes, sep="")
   }

   nrows <- nrow(mat)
   rows <- seq_len(nrows)
   for(i in rows)
   {
      zeroes <- paste(rep("0", nrows-i), collapse="")
      mat[i,] <- paste(mat[i,], zeroes, sep="")
   }

   #add zeroes to the start of the each number, so they are all the same length
   len <- max(nchar(mat))
   strcolumns <- formatC(cbind(as.vector(mat)), width=len)
   strcolumns <- gsub(" ", "0", strcolumns)

   #line up all the numbers below each other
   strmat <- matrix(unlist(strsplit(strcolumns, "")), byrow=TRUE, ncol=len)

   #convert to numeric and add them
   mat2 <- apply(strmat, 2, as.numeric)
   sum1 <- colSums(mat2)

   #repeat the process on each of the totals, until each total is a single digit
   repeat
   {
      ntotals <- length(sum1)
      totals <- seq_len(ntotals)
      for(i in totals)
      {
         zeroes <- paste(rep("0", ntotals-i), collapse="")
         sum1[i] <- paste(sum1[i], zeroes, sep="")
      }
      len2 <- max(nchar(sum1))
      strcolumns2 <- formatC(cbind(as.vector(sum1)), width=len2)
      strcolumns2 <- gsub(" ", "0", strcolumns2)
      strmat2 <- matrix(unlist(strsplit(strcolumns2, "")), byrow=TRUE, ncol=len2)
      mat3 <- apply(strmat2, 2, as.numeric)
      sum1 <- colSums(mat3)
      if(all(sum1 < 10)) break
   }

   #Concatenate the digits together
   ans <- paste(sum1, collapse="")
   ans
}

a <- "18446744073709551616"
longmult(a, a)


#load the package
library(readxl)
library(statebins)
library(MASS)
library(corrplot)
library(ggcorrplot)
library(ggplot2)
library(FactoMineR)
library(factoextra)
library(dplyr)
library(GGally)
library(reshape2)
library(RColorBrewer)
library(scales)
library(ggrepel)

#load the data
#the demographical data from U.S. census of 2016 (of 2015 if not available) https://www.census.gov/cps/data/cpstablecreator.html
#the relevant election data were obtained from following sources
#election result: http://edition.cnn.com/election/results
#turn-out rate: https://www.statisticbrain.com/2016-presidential-election-results-by-state/
#campaign travel log: http://storymaps.esri.com/stories/2016/campaign-travel-log/, http://traveltracker.nationaljournal.com
rawdata <- read_excel("electionswing2.xlsx", sheet="states")
rawdataagg <- read_excel("electionswing2.xlsx", sheet="swingyn")
View(rawdata)

#shape check
dim(rawdata)
#data type check
sapply(rawdata,class)

#change the column name
names(rawdata)[names(rawdata) == "X__1"] <- "Swing_States"

#practice corrplot package
#slice the data with only numerical column
corrdata <- rawdata[,2:53]
rownames(corrdata) <- rawdata$Swing_States

#generate correlation matrix
electionresult <- corrdata[,c("Vote_Clinton","Vote_Trump","Vote_Gap")]
variables = corrdata[,!(names(corrdata) %in% c("Vote_Clinton","Vote_Trump","Vote_Gap"))]
corr <- cor(x=electionresult, y=variables,  method="pearson")

#regarding p-value
#corr_pvalue <- cor_pmat(corrdata, method="pearson")
#corr_pvalue <- corr_pvalue[c("Vote_Clinton","Vote_Trump","Vote_Gap"),]
#corr_pvalue <- corr_pvalue[,colnames(corr_pvalue) != "Vote_Clinton"]
#corr_pvalue <- corr_pvalue[,colnames(corr_pvalue) != "Vote_Trump"]
#corr_pvalue <- corr_pvalue[,colnames(corr_pvalue) != "Vote_Gap"]

#melt correlation matrix using reshape package
melted_corrp <-melt(corr)

fig1 <- ggplot(data = melted_corrp, aes(x=Var1, y=Var2, fill=value)) +
geom_tile(color=melted_corrp$value) +
labs(title = "Correlation btw election result and attributes") +
geom_text(aes(label=round(melted_corrp$value,2)), color="black", size=2.8) +
scale_fill_gradient2(low = "red", high = muted("blue"), mid = "white", midpoint = 0, limit = c(-1,1),
space = "Lab", name="Pearson Correlation Analyses", guide="colourbar") +
theme_minimal() +
coord_fixed(ratio=0.2) +
theme(
  axis.title.x = element_blank(),
  axis.title.y = element_blank(),
  plot.title = element_text(size = rel(1)),
  panel.grid.major = element_blank(),
  panel.border = element_blank(),
  panel.background = element_blank(),
  axis.ticks = element_blank(),
  legend.position = "top",
  legend.title =element_text(size = 8.5)) +
guides(fill = guide_colorbar(direction = "horizontal", barwidth = 13, barheight=1, title.position = "top" ))
fig1

#additional wrangling
melted_corrp$tag <- ifelse(melted_corrp$value >= 0.4, "strong+", ifelse(melted_corrp$value <= -0.4, "strong-","-"))
melted_corrp$tag2 <- ifelse(melted_corrp$value >= 0.4, "strong+",ifelse(melted_corrp$value >=0.3, "moderate+", ifelse(melted_corrp$value <= -0.4, "strong-", ifelse(melted_corrp$value <= -0.3, "moderate-","-"))))

#scatter plot for selected attributes
#differ the size by the number of electoral vote
fig3 <-ggplot(data=rawdata, mapping=aes(x=Turn_Out_Rate_Asian, y=Vote_Clinton)) +
geom_point(mapping = aes(color=Swing_States, size=Electoral_Votes_Number))+
stat_smooth(method=lm, se=FALSE, size=1, linetype = "longdash", color="black")+
theme_minimal() +
geom_label_repel(aes(label = Swing_States), size=2.7, color='#566573')+
labs(title = "Correlation between Asian Turn-out rate and Vote% Clinton (r=0.69)") +
theme(axis.title.y = element_text(size=9, face= "bold"),
axis.title.x = element_text(size =9, face="bold"),
axis.text = element_text(size=8),legend.title =element_text(size = 10))
fig3

fig4 <-ggplot(data=rawdata, mapping=aes(x=Educational_Attainment_Bachelors_Degree, y=Vote_Gap)) +
geom_point(mapping = aes(color=Swing_States, size=Electoral_Votes_Number))+
stat_smooth(method=lm, se=FALSE, size=1, linetype = "longdash", color="black")+
theme_minimal() +
geom_label_repel(aes(label = Swing_States), size=2.7, color='#566573')+
labs(title = "Correlation between Bachelor's Degree attainment and Vote Gap (r=0.48)") +
theme(axis.title.y = element_text(size=9, face= "bold"),
axis.title.x = element_text(size =9, face="bold"),
axis.text = element_text(size=8),legend.title =element_text(size = 10))
fig4

fig5 <-ggplot(data=rawdata, mapping=aes(x=Age_60to80over, y=Vote_Trump)) +
geom_point(mapping = aes(color=Swing_States, size=Electoral_Votes_Number))+
stat_smooth(method=lm, se=FALSE, size=1, linetype = "longdash", color="black")+
theme_minimal() +
geom_label_repel(aes(label = Swing_States), size=2.7, color='#566573')+
labs(title = "Correlation between Age 60 + and Vote% Trump (r=0.55)") +
theme(axis.title.y = element_text(size=9, face= "bold"),
axis.title.x = element_text(size =9, face="bold"),
axis.text = element_text(size=8),legend.title =element_text(size = 10))
fig5

#the second heatmap considering impact

#agg2 <- rawdataagg[3,]
#agg2 <- t(agg2)
#colnames(agg2) <- c("figure")
#agg2 <- as.data.frame(agg2)
#agg2$Var2 <- rownames(agg2)
#agg2 <- agg2[c("Var2","figure")]
agg3 <- read.csv('agg2.csv')
agg3 <- select(agg3, -X)

melted_corr_impact <- melted_corrp[,c("Var1","Var2","value")]
melted_corr_impact <- merge(melted_corr_impact, agg3, by=c("Var2"))
melted_corr_impact$figure <- as.numeric(levels(melted_corr_impact$figure))[melted_corr_impact$figure]
melted_corr_impact$figure2 <- ifelse(melted_corr_impact$figure >= 1,1,melted_corr_impact$figure )
melted_corr_impact$figurefinal = melted_corr_impact$value * melted_corr_impact$figure2

fig2 <- ggplot(data = melted_corr_impact, aes(x=Var1, y=Var2, fill=figurefinal)) +
geom_tile(color=melted_corr_impact$figurefinal) +
labs(title = "Impact of attributes to election result") +
geom_text(aes(label=round(melted_corr_impact$figurefinal,2)), color="black", size=2.8) +
scale_fill_gradient2(low = "yellow", high = muted("green"), mid = "white", midpoint = 0, limit = c(-1,1),
space = "Lab", name="Impact of Attributes", guide="colourbar") +
theme_minimal() +
coord_fixed(ratio=0.2) +
theme(
  axis.title.x = element_blank(),
  axis.title.y = element_blank(),
  plot.title = element_text(size = rel(1)),
  panel.grid.major = element_blank(),
  panel.border = element_blank(),
  panel.background = element_blank(),
  axis.ticks = element_blank(),
  legend.position = "top",
  legend.title =element_text(size = 8.5)) +
guides(fill = guide_colorbar(direction = "horizontal", barwidth = 13, barheight=1, title.position = "top" ))
fig2

#additional table : write.csv()

#initial approach_pca

library(FactoMineR)
library(factoextra)
library(rgl)
library(plot3D)
library(car)
library(plotly)

#PCA용 로데이터 다시 생성

pcaraw <- rawdata[,1:49]
rownames(pcaraw) <- pcaraw$Swing_States
pcaraw <- select(pcaraw, -Swing_States)

res.pca <- PCA(pcaraw, scale.unit = TRUE, ncp = 3, graph = TRUE)
print(res.pca)

#check the eigenvalue table for each level of dimension
eig.val <- get_eigenvalue(res.pca)
eig.val

#The scree plot can be produced using the function fviz_eig() or fviz_screeplot() [factoextra package]
fviz_eig(res.pca, addlabels = TRUE, ylim=c(0,45), barfill = "#ff704d", barcolor="#ff704d", linecolor = "#800000", title = "Scree plot : % of explained variance by each PCA dimension")

#extract pca result for variables
var <- get_pca_var(res.pca)
var

#how well "each attribute" is explained by dimension 1,2,3
#how much variations are captured by each dimension !! (important)
variationcaptured <- var$cos2
print(variationcaptured)
corrplot(var$cos2, is.corr=FALSE)
fviz_cos2(res.pca, choice="var", axes = 1:3, fill ="#70dbdb", color ="#70dbdb", ggtheme = theme_minimal(),
xtickslab.rt = 90, title = "Bar chart : sum of cos2 (Dim1 + Dim2 + Dim3) for each attribute", labels = TRUE)

# Contributions of variables to PC1 - PC3
fviz_contrib(res.pca, choice = "var", axes = 1:3, top = 20)

#now move on to individual level
indvcorr <- res.pca$ind$coord
print(indvcorr)
indvcorr <- as.data.frame(indvcorr)

#pca plotting

#if plot_ly failed, alternatives.
x <- plot.x <- indvcorr$Dim.1
y <- plot.y <- indvcorr$Dim.2
z <- plot.z <- indvcorr$Dim.3
scatter3d(x,y,z, surface=FALSE, grid=FALSE, xlab = "PC1 (37.4%)", ylab = "PC2 (16.9%)",
        zlab = "PC3 (13.6%)", label=rownames(indvcorr), id.n=nrow(indvcorr), sphere.size = 1)

# plotly
fig6 <- plot_ly(indvcorr, type= "scatter3d", x = ~Dim.1, y = ~Dim.2, z = ~Dim.3,mode ='markers+text', text = rownames(indvcorr)) %>%
  add_annotations(x = indvcorr$Dim.1, y = indvcorr$Dim.2, z = indvcorr$Dim.3 , text = rownames(indvcorr), xref="x", yref="y", zref="z") %>%
  layout(scene = list(xaxis = list(title = 'PC1 (35.7%)'),
                     yaxis = list(title = 'PC2 (17.0%)'),
                     zaxis = list(title = 'PC3 (14.2%)')))
fig6

#참고 : how to drop columns in R
indvcorr <- select(indvcorr, -states)

#save for 2d plotting later
#fviz_pca_ind(res.pca$ind, geom.ind=c("point","text")) +
#labs(title = "Principal Component Analysis",  x = "PC1", y = "PC2")

#k-mean clustering
#clusterdf <- scale(indvcorr)

#find the optimal k
library(NbClust)
nbtest <- NbClust(indvcorr, distance = "euclidean", method = "kmeans", min.nc=2, max.nc=6)
fviz_nbclust(nbtest, barfill = "#ff3385", barcolor="#ff3385")

#do clustering with k=6
set.seed(200)
km.res <- kmeans(indvcorr, 6, nstart=50)
print(km.res)

#do clustering with k=5
set.seed(200)
km.res2 <- kmeans(indvcorr, 5, nstart=50)
print(km.res2)

#do clustering with k=2
set.seed(200)
km.res3 <- kmeans(indvcorr, 2, nstart=50)
print(km.res3)

#merge the cluster result to the original data and do some cleansing
clusterresultk5<- as.data.frame(km.res2$cluster)
clusterresultk5$Swing_States <- rownames(clusterresultk5)
rawwithcluster <- merge(rawdata, clusterresultk5, by=c("Swing_States"))

pcawithcluster <- indvcorr
pcawithcluster$Swing_States<- rownames(pcawithcluster)

pcawithcluster <- merge(pcawithcluster, clusterresultk5, by=c("Swing_States"))
names(pcawithcluster)[names(pcawithcluster) == "km.res2$cluster"] <- "cluster_result"
pcawithcluster$cluster <- paste("cluster", pcawithcluster$cluster_result)

pcawithcluster <- merge(pcawithcluster,rawdata[,c("Electoral_Votes_Number","Swing_States")], by=c("Swing_States"))

#plot again with different colour for each cluster

fig7 <- plot_ly(pcawithcluster, type= "scatter3d", x = ~Dim.1, y = ~Dim.2, z = ~Dim.3,mode ='markers+text', color=~cluster, text = ~Swing_States,
marker = list(symbol = 'circle', sizemode = 'diameter'), sizes = 15, textfont = list(size=15)) %>%
  add_annotations(x = pcawithcluster$Dim.1, y = pcawithcluster$Dim.2, z = pcawithcluster$Dim.3 , text = pcawithcluster$Swing_States, xref="x", yref="y", zref="z") %>%
  layout(title = 'Clustering result for US Swing States', scene = list(xaxis = list(title = 'PC1 (35.7%)'),
                     yaxis = list(title = 'PC2 (17.0%)'),
                     zaxis = list(title = 'PC3 (14.2%)')))
fig7

#plot clustering result into statebins
library(statebins)
clustermap <- read_excel("clustermap.xlsx")

fig8 <- statebins(state_data = clustermap, state_col = "st", value_col = "ing", text_color = "white", breaks=6,
labels = 0:5, font_size=4, brewer_pal="Paired", plot_title = "US Swing States Cluster Map (k=5)", title_position = "top", legend_position="none")
fig8

#raw for polar radar chart (not weighted ver.)

names(rawwithcluster)[names(rawwithcluster) == "km.res2$cluster"] <- "cluster_result"
rawwithcluster$cluster <- paste("cluster", rawwithcluster$cluster_result)
rawforpolar_test <- aggregate(rawwithcluster[,2:53], by=list(rawwithcluster$cluster), FUN=mean, narm=TRUE)
rawforpolar_test <- select(rawforpolar_test, -c(Vote_Clinton,Vote_Trump,Vote_Gap))

#z-score standardisation

rawforpolarz <- as.data.frame(scale(rawforpolar_test[,2:50]))
rownames(rawforpolarz) <- c("cluster 1", "cluster 2", "cluster 3","cluster 4","cluster 5")

write.csv(rawforpolarz, 'polarpolar.csv')


# Load tag intent data and calculate inter-rater agreement

json.tagRes <- read.csv(file="json_pilot_reasons.csv", header = TRUE)
django.tagRes <- read.csv(file="django_pilot_reasons.csv", header = TRUE)
regex.tagRes <- read.csv(file="regex_pilot_reasons.csv", header = TRUE)

# load the library
library(irr)

kappam.fleiss(json.tagRes[c("Rater1", "Rater2", "Rater3")])

kappam.fleiss(django.tagRes[c("Rater1", "Rater2", "Rater3")])

kappam.fleiss(regex.tagRes[c("Rater1", "Rater2", "Rater3")])

tagRes <- rbind(json.tagRes, django.tagRes, regex.tagRes)
kappam.fleiss(tagRes[c("Rater1", "Rater2", "Rater3")])


#!/usr/bin/env Rscript
# Finds the median engagement rate of the tweets in a CSV file
# and then prints lists for tweets that are above and tweets
# that are below the median.

file <- commandArgs( 1 )
tweets <- read.csv( file, header = TRUE )

# Convert engagement.rate column to number vector
rates <- as.vector( tweets[,"engagement.rate"] )
for( n in 1:length( rates ) ) {
	rates[n] <- as.numeric( rates[n] )
}

median.engagement = median( rates )

# Find subset of table where engagement.rate > median.engagement
print( "Tweets with above-average engagement:" );
for( row in 1:nrow( tweets ) ) {
	engagement <- as.numeric( tweets[row, "engagement.rate"] )
	if( engagement > median.engagement ) {
		print( tweets[row, "Tweet.text"] )
	}
}

# Find subset of table where engagement.rate <= median.engagement
print( "Tweets with below-average engagement:" );
for( row in 1:nrow( tweets ) ) {
	engagement <- as.numeric( tweets[row, "engagement.rate"] )
	if( engagement <= median.engagement ) {
		print( tweets[row, "Tweet.text"] )
	}
}


library(e1071)
library(ggplot2)
library(purrr)
library(tidyverse)

#
data("iris")
svm_model <- svm(Species ~ Sepal.Length+Petal.Length, data=iris)
plot(svm_model, iris, Sepal.Length~Petal.Length)

#
data("mtcars")
mod=svm(as.factor(cyl)~wt+disp,data=mtcars)
plot(mod,mtcars,wt~disp)

#
library(ggplot2)
data("DNase")
d=DNase
ggplot(d)+geom_point(aes(conc,density,color=Run))

#
data("Orange")
org=Orange
org.svm=svm(as.factor(Tree)~.,org)
plot(org.svm,org,age~circumference)

#
library(lattice) ##for the dataset
data("environmental")
en=environmental
en.lm=lm(ozone~.,en)
plot(predict(en.lm,en),en$ozone)

#
data("starwars")
stw=starwars
stw=na.omit(stw)
stw
stw_svm=svm(as.factor(sex)~height+mass,stw)
plot(stw_svm,stw,height~mass)

#
data("starwars")
stw=starwars
stw=na.omit(stw)
stw
stw_svm=svm(as.factor(homeworld)~mass+height+birth_year,stw)
plot(stw_svm,stw,height~mass)


#######DESCRIPTION###############################
#fits 'rating curves' between oserved downstream discharge and upstream stage
#fits 'rating curves' between calcuated discharge and upstream stage
#saves as rdata object for use in flood forecasting code
#################################################
##load libraries
library(tools)
library(ncdf4)
library(dplyr)
library(data.table)
library(ggplot2)
library(minpack.lm)
library(hydroGOF)
library(R.utils)
library(scales)
library(RColorBrewer)
nlc = nls.control(maxiter = 1000)

##user inputs
#processed data location
dir_dat = '/Volumes/gonggong/flood forecasting/data/'
#reference table location
dir_ref = '/Volumes/gonggong/flood forecasting/data/reference tables/'
#plot location (if desired)
dir_plots = '/Users/danbroman/Google Drive/Graduate School/Flood Forecasting/'
npts_thresh = 20
nse_thresh = 0.1

##read in data
stage_dat = readRDS(file.path(dir_dat, 'stage.rda'))
stage_weight_tbl = readRDS(file.path(dir_ref, 'stage_weight_tbl.rda'))

##mutate data
stage_dat_day = stage_dat %>% dplyr::mutate(date = as.Date(date)) %>% dplyr::filter(hour %in% c(6:18)) %>% dplyr::mutate(hour_min = hour - 12) %>% group_by(date, sta_id) %>% dplyr::slice(which.min(hour_min)) %>% ungroup() %>% dplyr::select(date, sta_id, basin, stage) %>% data.table()

##fit rating curves
rating_curve_set = data.table(stage_weight_tbl, lag = rep(0:20, each = nrow(stage_weight_tbl)))

rating_curve_tbl = NULL
for(i in 1:nrow(rating_curve_set)){
	sta_id_temp = rating_curve_set$sta_id[i]
	sta_id_us_temp = rating_curve_set$sta_id_us[i]
	lag_temp = rating_curve_set$lag[i]
	stage_fcst_ds_temp = stage_dat_day %>% dplyr::filter(sta_id == sta_id_temp) %>% dplyr::select(date, stage) %>% data.table()
	stage_fcst_us_temp = stage_dat_day %>% dplyr::filter(sta_id == sta_id_us_temp) %>% dplyr::mutate(date = date - lag_temp) %>% dplyr::rename(stage_us = stage) %>% dplyr::select(date, stage_us)
	stage_stage = stage_fcst_ds_temp %>% left_join(stage_fcst_us_temp) %>% dplyr::filter(!is.na(stage), !is.na(stage_us))

	rating_curve_temp = data.table(sta_id = sta_id_us_temp, lag = lag_temp, C = NA, a = NA, n = NA, nse = NA, scale = scale_temp, sta_id_ds = sta_id_temp, npts = NA, err = NA)
	fit_dat = stage_stage %>% dplyr::select(stage, stage_us)
	if(nrow(fit_dat) > 0){
		power.nls = try(nlsLM(stage~C*(stage_us+a)^n, data = fit_dat, start = list(C=1, a=0, n=1), control = nlc))
		if(class(power.nls) != 'try-error'){
			fit_pred = predict(power.nls)
			nse_skill = round(NSE(fit_pred, fit_dat$stage), 4)
			npts = nrow(fit_dat)
			err = (1 / npts) * sum((fit_dat$stage - fit_pred)^2)
			rating_curve_temp = data.table(sta_id = sta_id_us_temp, lag = lag_temp, C = coef(power.nls)["C"], a = coef(power.nls)["a"], n = coef(power.nls)["n"], nse = nse_skill, npts = nrow(fit_dat), scale = scale_temp, sta_id_ds = sta_id_temp, npts = npts, err = err)  #stores current station rating curve values
		}
	}
	rating_curve_tbl = bind_rows(rating_curve_tbl, rating_curve_temp)
}

#save data
saveRDS(rating_curve_tbl, paste0(dir_dat, 'rating_curve_stage.rda'))
rating_curve_tbl = rating_curve_tbl %>% dplyr::filter(nse >= nse_thresh, npts >= npts_thresh, !is.na(C))
saveRDS(rating_curve_tbl, paste0(dir_dat, 'rating_curve_stage_fl.rda'))


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

#####     LABELS      ######

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

#superindex: ^
lab1 <- expression(paste("cells ",ml^-1))
plot(x=1:10,y=1:10, type='n',xlab=lab1)

#subindex: []
lab2 <- expression(paste(log[10]," Abundance"))
plot(x=1:10,y=1:10, type='n',xlab=lab2)

#greek leters (mu , pi)
lab3 <- expression(paste("diameter ",mu,"m"))
plot(x=1:10,y=1:10, type='n',xlab=lab3)

#degree C
lab4 <- expression(paste("Temperature ",degree*C)) ## no space
lab5 <- expression(paste("Temperature ",degree~C)) ## space
plot(x=1:10,y=1:10, type='n',xlab=lab4, ylab=lab5)

#italics
lab6 <- expression(italic("Synechococcus"))
plot(x=1:10,y=1:10, type='n',xlab=lab6)

#bold
lab7 <- expression(bold ("nmol"))
plot(x=1:10,y=1:10, type='n',xlab=lab7)