## 1. Introduction ##

library(readr)

mvc  <-  read_csv("nypd_mvc_2018.csv")
na_logical  <-  is.na(mvc)

## 2. Summing Values Over Rows ##

library(dplyr)

mvc_na <- data.frame(is.na(mvc))
mvc_na_injured <- mvc_na %>%
    mutate(total_na_injured = rowSums(.[9:11]))

## 3. Verifying the Total Columns ##

killed  <-  mvc %>% select(ends_with("_killed"))
killed_non_eq <- killed %>%
    mutate(manual_sum = rowSums(.[1:3])) %>%
    filter(manual_sum != total_killed | is.na(total_killed))

## 4. Filling and Verifying the Killed and Injured Data ##

# fix the killed values
killed_non_eq <- killed_non_eq %>%
    mutate(total_killed = if_else(is.na(total_killed), manual_sum, total_killed ))

killed_non_eq <- killed_non_eq %>%
    mutate(total_killed = if_else(total_killed != manual_sum, NaN, total_killed ))

# Create an injured_non_eq dataframe and manually sum values
injured  <-  mvc %>% select(ends_with("_injured"))

injured_non_eq <- injured %>%
    mutate(manual_sum = rowSums(.[1:3])) %>%
    filter(manual_sum != total_injured | is.na(total_injured))
injured_non_eq <- injured_non_eq %>%
    mutate(total_injured = if_else(is.na(total_injured), manual_sum, total_injured ))

injured_non_eq <- injured_non_eq %>%
    mutate(total_injured = if_else(total_injured != manual_sum, NaN, total_injured ))

## 5. Preparing Data for Missing Data Visualization ##

library(purrr)

mvc_na <- map_df(mvc, function(x) as.numeric(is.na(x)))
library(tidyr)

mvc_na_heat <- mvc_na %>%
    pivot_longer(cols = everything(),
               names_to = "x") %>%
    group_by(x) %>%
    mutate(y = row_number())

## 6. Visualizing Missing Data with Heatmaps ##

plot_na_matrix <- function(df) {
    # Preparing the dataframe for heatmaps
    df_heat <- df %>%
        pivot_longer(cols = everything(),
               names_to = "x") %>%
        group_by(x) %>%
        mutate(y = row_number())

    # Ensuring the order of columns is kept as it is
    df_heat <- df_heat %>%
        ungroup() %>%
        mutate(x = factor(x,levels = colnames(df)))

    # Plotting data
    g <- ggplot(data = df_heat, aes(x=x, y=y, fill=value)) +
        geom_tile() +
        theme(legend.position = "none",
              axis.title.y=element_blank(),
              axis.text.y =element_blank(),
              axis.ticks.y=element_blank(),
              axis.title.x=element_blank(),
              axis.text.x = element_text(angle = 90, hjust = 1))

    # Returning the plot
    g
}
library(ggplot2)

mvc_na_vehicle <- mvc_na %>% select(contains("vehicle"))
plot_na_matrix(mvc_na_vehicle)

## 7. Visualizing Correlation Matrix with Heatmaps ##

#plot na correlation helper
plot_na_correlation <- function(df) {
    # Taking the lower triangle of the correlation matrix
    missing_corr_up <- df
    missing_corr_up[lower.tri(missing_corr_up)] <- NA
    missing_corr_up <- data.frame(missing_corr_up)

    # Preparing the dataframe for heatmaps
    col_names <- colnames(missing_corr_up)

    missing_corr_up_heat <- missing_corr_up %>%
        pivot_longer(cols = everything(),
               names_to = "x") %>%
        group_by(x) %>%
        mutate(y = col_names[row_number()])  %>%
        na.omit

    # Ordering triangle
    ordered_cols_asc <- col_names[order(colSums(is.na(missing_corr_up)))]
    ordered_cols_desc <- col_names[order(-colSums(is.na(missing_corr_up)))]

    missing_corr_up_heat <- missing_corr_up_heat %>%
        ungroup() %>%
        mutate(x = factor(x,levels = ordered_cols_asc)) %>%
        mutate(y = factor(y,levels = ordered_cols_desc))

    # Plotting heatmaps
    g <- ggplot(data = missing_corr_up_heat, aes(x=x, y=y, fill=value)) +
        geom_tile() +
        geom_text(aes(label=value)) +
        theme_minimal() +
        scale_fill_gradientn(colours = c("white", "yellow", "red"), values = c(-1,0,1)) +
        theme(legend.position = "none",
              axis.title.y=element_blank(),
              axis.title.x=element_blank(),
              axis.text.x = element_text(angle = 90, hjust = 1))

    # Returning the plot
    g
}
mvc_na_vehicle <- mvc_na %>% select(contains("vehicle"))
missing_vehicle_corr  <-  round(cor(mvc_na_vehicle), 2)

plot_na_correlation(missing_vehicle_corr)

## 8. Analyzing Correlations in Missing Data ##

library(purrr)

col_labels  <-  c('v_number', 'vehicle_missing', 'cause_missing')

v_fun <- function(x){
    v_col <- paste('vehicle', x,  sep = "_" )
    c_col <- paste('cause_vehicle', x,  sep = "_" )
    sum(is.na(mvc[v_col]) & !is.na(mvc[c_col]))
}
v_na <- map_int(1:5, v_fun )
c_fun <- function(x){
    v_col <- paste('vehicle', x,  sep = "_" )
    c_col <- paste('cause_vehicle', x,  sep = "_" )
    sum(!is.na(mvc[v_col]) & is.na(mvc[c_col]))
}
c_na <- map_int(1:5, c_fun )

vc_na_df  <-  tibble(1:5, v_na, c_na)
colnames(vc_na_df) <- col_labels

## 9. Finding the Most Common Values Across Multiple Columns ##

vehicles  <-  mvc %>% select(starts_with("vehicle_"))
head(vehicles)
library(tidyr)

vehicles_1d  <-  vehicles %>% pivot_longer(cols = everything())

vehicles_counts  <-  table(vehicles_1d$value)
top10_vehicles  <-  head(sort(vehicles_counts, decreasing = T), 10)

top10_vehicles

## 10. Filling Unknown Values with a Placeholder ##

v_fun <- function(x){
    v_col <- paste('vehicle', x,  sep = "_" )
    c_col <- paste('cause_vehicle', x,  sep = "_" )
    sum(is.na(mvc[v_col]) & !is.na(mvc[c_col]))
}

c_fun <- function(x){
    v_col <- paste('vehicle', x,  sep = "_" )
    c_col <- paste('cause_vehicle', x,  sep = "_" )
    sum(!is.na(mvc[v_col]) & is.na(mvc[c_col]))
}

summarize_missing <- function(){
    library(purrr)

    col_labels  <-  c('v_number', 'vehicle_missing', 'cause_missing')

    v_na <- map_int(1:5, v_fun )
    c_na <- map_int(1:5, c_fun )

    vc_na_df  <-  tibble(1:5, v_na, c_na)
    colnames(vc_na_df) <- col_labels
    vc_na_df
}

summary_before  <-  summarize_missing()

# for (x in 1:5 ){
#    v_col <- paste('vehicle', x,  sep = "_" )
#    c_col <- paste('cause_vehicle', x,  sep = "_" )
for (x in 1:5 ){
    v_col <- paste('vehicle', x,  sep = "_" )
    c_col <- paste('cause_vehicle', x,  sep = "_" )

    # create a logical vector for each column
    v_missing_logical  <-  is.na(mvc[v_col]) & !is.na(mvc[c_col])
    c_missing_logical  <-  !is.na(mvc[v_col]) & is.na(mvc[c_col])

    # replace the values matching the logical vector for each column
    mvc <- mvc %>%
        mutate_at(c(v_col), function(x) if_else(v_missing_logical,"Unspecified", v_col ))

    mvc <- mvc %>%
        mutate_at(c(c_col), function(x) if_else(c_missing_logical,"Unspecified", c_col ))
}

summary_after  <-  summarize_missing()

## 12. Imputing Location Data ##

library(readr)

sup_data  <-  read_csv('supplemental_data.csv')

location_cols  <-  c('location', 'on_street', 'off_street', 'borough')
na_before  <-  colSums(is.na(mvc[location_cols]))
for (col in location_cols ) {
    mvc[is.na(mvc[col]),col] <- sup_data[is.na(mvc[col]),col]
}

na_after  <-  colSums(is.na(mvc[location_cols]))

Data Analyst in R/Step 3 - Data Cleaning in R/2. Data Cleaning in R Advanced/4. Working with Missing Data.r


par(mfrow=c(1,3))
STK=na.omit(get(getSymbols("2330.TW")))
STK=to.weekly(STK)
STK=as.matrix(STK)
###??
PL=setNames(numeric(nrow(STK)),rownames(STK))
#for (m in rownames(STK)){
for (m in 2:nrow(STK)){
# if (Op(STK)[m]<Cl(STK)[m-1]){
PL[m]=STK[m,4]-STK[m,1]
# }
}
plot(cumsum(PL),type="l",col="blue",lwd=2)
abline(h=0,col="green")
###??
PL=setNames(numeric(nrow(STK)),rownames(STK))
#for (m in rownames(STK)){
for (m in 2:nrow(STK)){
if (Op(STK)[m]>Cl(STK)[m-1]){
PL[m]=STK[m,4]-STK[m,1]
}
}
plot(cumsum(PL),type="l",col="red",lwd=2)
abline(h=0,col="green")
#####
PL=setNames(numeric(nrow(STK)),rownames(STK))
#for (m in rownames(STK)){
for (m in 2:nrow(STK)){
if (Op(STK)[m]<=Cl(STK)[m-1]){
PL[m]=STK[m,4]-STK[m,1]
}
}
plot(cumsum(PL),type="l",col="green",lwd=2)
abline(h=0,col="green")


context("coord_polar")

test_that("Polar distance calculation", {
  dat <- data.frame(
    theta = c(0, 2*pi,   2,   6, 6, 1,    1,  0),
    r     = c(0,    0, 0.5, 0.5, 1, 1, 0.75, .5))

  scales <- list(x = scale_x_continuous(limits=c(0, 2*pi)),
                 y = scale_y_continuous(limits=c(0, 1)))
  coord <- coord_train(coord_polar(), scales)

  dists <- coord_distance(coord_polar(), dat$theta, dat$r, coord)

  # dists is normalized by dividing by this value, so we'll add it back
  # The maximum length of a spiral arc, from (t,r) = (0,0) to (2*pi,1)
  maxlen <- spiral_arc_length(1 / (2 * pi), 0, 2 * pi)

  # These are the expected lengths. I think they're correct...
  expect_equal(dists,
    c(0, -1.225737494, -2, -0.5, -5, -0.25, -0.6736885011) / maxlen)

  # The picture can be visualized with:
  # ggplot(dat, aes(x=theta, y=r)) + geom_path() +
  #   geom_point(alpha=0.3) + coord_polar()
})

test_that("Polar distance calculation ignores NA's", {

  # These are r and theta values; we'll swap them around for testing
  x1 <- c(0, 0.5, 0.5, NA, 1)
  x2 <- c(0,   1,   2, 0,  1)

  dists <- dist_polar(x1, x2)
  expect_equal(is.na(dists), c(FALSE, FALSE, TRUE, TRUE))
  dists <- dist_polar(x2, x1)
  expect_equal(is.na(dists), c(FALSE, FALSE, TRUE, TRUE))

  # NA on the end
  x1 <- c(0, 0.5, 0.5, 1, NA)
  x2 <- c(0,   1,   2, 0,  1)
  dists <- dist_polar(x1, x2)
  expect_equal(is.na(dists), c(FALSE, FALSE, FALSE, TRUE))
  dists <- dist_polar(x2, x1)
  expect_equal(is.na(dists), c(FALSE, FALSE, FALSE, TRUE))

  # NAs in each vector - also have NaN
  x1 <- c(0, 0.5, 0.5,  1, NA)
  x2 <- c(NaN,   1,   2, NA,  1)
  dists <- dist_polar(x1, x2)
  expect_equal(is.na(dists), c(TRUE, FALSE, TRUE, TRUE))
  dists <- dist_polar(x2, x1)
  expect_equal(is.na(dists), c(TRUE, FALSE, TRUE, TRUE))
})


#==============================================================================
#	Unit test of regression.metrics.calculator class.
#==============================================================================
library(testthat)
library(cv.models)

#------------------------------------------------------------------------------
context("Unit test for regression.metrics.calculator class.")

#------------------------------------------------------------------------------
#	Create test data for 'fit'.
#
#	Expected metrics:
#		MSE = 0.1
#		RMSE = sqrt(0.1)
#		R^2 = 0.9929162
#		Q^2 = 0.9891775
#------------------------------------------------------------------------------
create.test.fit <- function() {
	fit <- list(
		response = 1:10, prediction = 1:10
	)
	fit$response[10] <- fit$response[10] + 1
	return(fit)
}

#------------------------------------------------------------------------------
test_that(
	"Test format of result returned by regression.metrics.calculator.", {
		# Prepare information for testing.
		fit <- create.test.fit()
		object <- cv.models:::regression.metrics.calculator$new()
		metrics <- object$calculate.metrics(fit)
		# Check data format.
		expect_is(metrics, "list", "Test the result is a list.")
		expect_true(
			all(sapply(metrics, is.matrix)),
			"Test all elements in the list are matrix."
		)
	}
)

#------------------------------------------------------------------------------
test_that(
	"Test values returned by regression.metrics.calculator.", {
	# Prepare information for testing.
		fit <- create.test.fit()
		object <- cv.models:::regression.metrics.calculator$new()
		metrics <- object$calculate.metrics(fit)
		# Check values.
		# Because expect_equal produces error because reference values don't
		# have names, following tests use expect_equivalent.
		expect_equivalent(
			metrics[[1]][, "mse"], 0.1, info = "Test value of MSE."
		)
		expect_equivalent(
			metrics[[1]][, "rmse"], sqrt(0.1), info = "Test value of RMSE."
		)
		expect_equivalent(
			metrics[[1]][, "r.squared"], cor(fit$response, fit$prediction) ^ 2,
			info = "Test value of R^2."
		)
		q2 = 1 - 1 / sum((fit$response - mean(fit$response)) ^ 2)
		expect_equivalent(
			metrics[[1]][, "q.squared"], q2, info = "Test value of Q^2."
		)
	}
)

rm(create.test.fit)


# distances between points with nearest neighbor approx

# x = c(1,2,3,4,5,6,7,8,9)
# y = c(1,2,3,4,5,6,7,8,9)
#
# a = x + 2
# b = y * 2
#
# all = c(a,b,x,y)
# plot(a,b,pch = 20, ylim = c(min(all), max(all)), xlim = c(min(all), max(all)), asp = 1)
# points(x,y,pch = 20, col = 'red')
#
#
# X = cbind(x,y)
# A = cbind(a,b)

nearest_xy = function(A,X,to = 1, plot = F) {

	Z = as.matrix(dist(rbind(X,A)))

	aseq = ((length(x)+1):length(c(x,a))); xseq = (1:(length(x)))

	Z = Z [ aseq , xseq ]

	# so now have distances between every point in each xy dataset. now pick which set to choose the nearest neighbor

	# if the A dataset is the one to match to...
	if (to == 1) {
		v = apply(Z, 1, 'min')

		j = 1
		m = c()
		for (i in aseq) {
			jkl = Z[paste0(i),]
			lkj = which(jkl %in% v[paste0(i)])[1]
			m[j] = lkj
			j = j + 1
		}

		T = cbind(A,X[m,])
	}

	# if the X dataset is the one to match to...

	else if (to == 2) {
		v = apply(Z, 2, 'min')

		j = 1
		m = c()
		for (i in xseq) {
			jkl = Z[,paste0(i)]
			lkj = which(jkl %in% v[paste0(i)])[1]
			m[j] = lkj
			j = j + 1
		}

		T = cbind(X,A[m,])
	}

	else {stop('pick a variable to match to.')}

	if (plot == T) {
		par(bg = 'grey90')
		plot(T[,1], T[,2], type = 'n', ylim = c(min(all), max(all)), xlim = c(min(all), max(all)), asp = 1)

		points(X[,1], X[,2], col = 'black', pch = 20)
		points(A[,1], A[,2], col = 'blue3', pch = 20)

		points(T[,3], T[,4], col = 'red3', pch = 1, cex = 1.5)

		segments(T[,1], T[,2],T[,3], T[,4], col = 'red3', lty = 3)
	}
}


context("Breaks - log")

test_that("Five ticks over 10^4 range work", {
  expect_equal(log_breaks()(10^(1:5)), 10^(1:5))
})

test_that("use integer base powers when at least 3 breaks are within range", {
  base <- 10
  expect_equal(
    log_breaks(base = base)(base^c(0, 2)),
    base^(0:2)
  )
  base <- 4
  expect_equal(
    log_breaks(base = base)(base^c(0, 2)),
    base^(0:2)
  )
  base <- 2
  expect_equal(
    log_breaks(base = base)(base^c(0, 2)),
    base^(0:2)
  )
})

test_that("add intermediate breaks when more breaks are needed", {
  base <- 10
  expect_equal(
    log_breaks(base = base)(base^c(2, 4) + c(1, -1)),
    c(100, 300, 1000, 3000, 10000)
  )
  expect_equal(
    log_breaks(base = base)(base^c(2, 3) + c(1, -1)),
    c(100, 200, 300, 500, 1000)
  )
  base <- 4
  expect_equal(
    log_breaks(base = base)(base^c(2, 4) + c(1, -1)),
    c(16, 32, 64, 128, 256)
  )
  base <- 3
  expect_equal(
    log_breaks(base = base)(base^c(2, 4) + c(1, -1)),
    c(9, 18, 27, 54, 81)
  )
  base <- 2
  expect_equal(
    log_breaks(n = 5, base = 2)(c(3, 100)),
    c(2, 4, 8, 16, 32, 64, 128)
  )
})

test_that("log_breaks arguments are forcely evaluated on each call #81", {
  subfun1 <- log_breaks(n = 5, base = 10)
  subfun2 <- log_breaks(n = 20, base = 5)

  subfuns <- list()
  cases_n <- c(5, 20)
  cases_base <- c(10, 5)
  for (i in 1:2) {
    subfuns[[i]] <- log_breaks(n = cases_n[i], base = cases_base[i])
  }
  expect_equal(subfun1(1:1000), subfuns[[1]](1:1000))
  expect_equal(subfun2(1:1000), subfuns[[2]](1:1000))
})


# Error, residual y e.
#################################################################
cat("\014")
rm(list=ls())
graphics.off()

# En esta clase, trabajaremos con una base famosa que se llama
# "Correlates of War". Es ampliamente usada para estudiar conflicto armado,
# uno de los temas que estudia la ciencia politica.

# En esta clase pensaremos en la siguiente pregunta: cual es la relacion entre
# represion politica y democracia. La unidad de analisis es el pais.
# Quienes reprimen mas, paises democraticos o dictatoriales? Para responder,
# deberemos volver a pensar en beta1.

# Abramos la base de datos. Los formatos ".dta" son de Stata. Esa es otra
# ventaja de R: R puede abrir bases de datos de Stata (pero Stata no puede
# abrir bases de datos de R, ni de nada mas que no sea Stata).

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

# Cargar paquete para cargar bases que no son de R.
# install.packages("foreign")
p_load(foreign) # significa "foraneo"
options(scipen = 1000000) # apagar notacion cientifica.
dat = read.dta("https://github.com/hbahamonde/OLS/raw/master/Datasets/cow.dta")

# Siempre inspeccionar base
head(dat)

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

# Otro truco: graficar la base entera.
plot(dat)

########################
# Regresion Simple
########################

# Corramos una regresion bivariada, es decir, una sola variable independiente.
# Es "bi"-variada porque inspecciona la relacion solo entre DOS variables:
# la dependiente y la independiente.

reg.bivariada = lm(repression ~ democracy, dat)
summary(reg.bivariada) # Hoy solo miraremos los coeficientes. Otro dia veremos el error std.

# (1) Como podriamos interpretar esto?
# (2) Como podriamos escribir esto en forma de ecuacion?
# (3) Como podriamos escribir esto en forma de matrix?

# Veamos la guia en el pdf.

# Calculando el error. El error es la diferencia entre lo que vemos y lo que predecimos.
# Es decir entre "y" (niveles reales de repression)
# y "y'" (y prima), (niveles predecidos de represion).

# Primero, calculemos y'
dat$repression.prima = predict.lm(reg.bivariada)

# Segundo, calculemos el error:
dat$error = dat$repression-dat$repression.prima

# Recordemos que el objeto que sale de "lm" ya contiene los residuos.
as.numeric(reg.bivariada$residuals)

# Veamos...
head(dat)

# Ok. Esto implica lo siguiente:
## (1) Hay mejores modelos que otros. Los mejores, son los que tienen menos error.
## (2) El error representa todo lo que no podemos conocer ni medir apropiadamente. Ejemplos?
## (3) El error esta normalmente distribuido y debe tener promedio 0.
  ## (3.1) Filosoficamente: lo que no conocemos, no es sistematico (es al azar).
  ## (3.2) Matematicamente: lo que no conocemos, debe tener promedio 0.

# Graficando el error
p_load(lattice) # Paquete para graficos
densityplot(dat$error)
# Muy cerca del 0.

# Veamos mas en detalle:
summary(dat$error) # Que promedio tiene el error?

# Comparemos el error que computamos nosotros, con el descriptivo del error que calcula R
round(median(dat$error),4) == round(median(reg.bivariada$residuals),4)

# Puntos importantes:
# (1.1) Siempre se dice que "los errores se cancelan mutuamente"
# (1.2) Ej.: error de medicion en encuestas (mentirosos).

# Una manera grafica de ver el error, es ver un scatter plot
# entre el error y el valor real.

plot(reg.bivariada$residuals, reg.bivariada$fitted.values)

# Residuos deben ser HOMOESQUEDASTICOS (VARIANZA CONSTANTE).

# (1) Como seria un grafico donde hay problemas?
# (2) Como pensar en la "normalidad" del error graficamente?
# (3.1) Un "buen" error "no tiene patrones claros".
# Dibujar un ejemplo.
# (4) Razones por las que incrementa nuestro error?

########################
# Regresion Multiple
########################

# Regresion "multiple" o "multivariada" tiene mas de una variable "independiente".

# Pensemos en la idea de que una variable sea "independiente".
# Para ello, pensemos en nuestra ecuacion lineal de nuevo.

# y = b0 + b1x1 + e (esta es bivariada: una "x")
# y = b0 + b1x1 + b2x2 + b3x3 + e ("multivariada" o "multiple").

# (1) Por que se llama "independiente"?
# (2) Importa en que orden vayan las variables?
# (3) Cuantas variables independientes podemos tener?
# (4) Que variables independientes NO PODEMOS tener?

# (4.1) No podemos poner la misma variable a los dos lados del "="
# Es decir, no podemos estimar "y ~ y" (o "x ~ x").

# Pensemos en las notas del ramo de Matematicas de Pedro y Juan.
pj = data.frame(
  nombre=c("Pedro", "Juan"),
  nota.en.matematicas=c(3,5)
  )

pj # ve como se ve el objeto "pj".

lm(pj$nota.en.matematicas ~ pj$nota.en.matematicas) # Error

# (4.2) La misma variable independiente dos veces:

# Es decir, y = x1 + x1 NO SE PUEDE. Veamos por que.

# Volvamos a Pedro y Juan (y dejemos a Diego fuera mientras).

# Pensemos nuevamente en las notas en Matematicas de Pedro y Juan.
data.frame(
  nombre=c("Pedro", "Juan"),
  nota.en.matamticas=c(3,5)
  )

# Ahora, entremos las notas de Pedro y Juan en una matriz DOS VECES.
# La matriz se llama "x".
x = matrix(
  c(3,5,3,5),
  ncol = 2
  )
x

# Fijate que la primera y la segunda columna significan lo mismo ("notas en matematicas").

# Volvamos al modelo. Queremos ver que la ecuacion de regresion con dos variables
# independientes que son identicas es imposible. Es decir, esto es imposible:

# y = b0 + b1x1 + b2x1 + e
# donde "x1" es "Notas en Matematicas" (fijate que x1 que entro dos veces).

# Tratemos de estimar los betas via matrices.
# (x'x)^-1x'y (esta es la formula...solo para recordar).
# Ahora veamos si es posible hacer esto cuando estimamos el modelo x = x.

# Transponer x
t(x) # Ok, es posible

# Multiplicar x'x
t(x) %*% x # Ok, es posible

# Ahora, siguiendo la formula, tratemos de inviertir (x'x)
library(matlib) # para invertir matrices
inv(t(x) %*% x) # Matriz no es invertible
## Esto significa que la determinante de la matriz es 0.

# Es por esto que lm() no sabe muy bien que hacer con este problema. Veamos.

## Intento 1
summary(lm(repression ~ democracy + democracy, dat)) # Que paso aqui?

# Forcemos a R a hacerlo
# Intento 2
dat$democracy2 = dat$democracy # Enganando a R...
summary(lm(repression ~ democracy + democracy2, dat)) # Que paso aqui?

# Nuevamente det(x'x)=0.

# Tecnicamente, aqui tenemos problemas de "colinearidad perfecta"

# Ejemplo 1: Colinearidad Perfecta (de nuevo)
m1 = matrix(c(3,5,3,5), ncol = 2) # Define matrix "m"
m1 # ve como se ve la matrix "m1"

# El resultado sera muy cercano a 0, y sera un numero muy
# pequeno, por lo que debemos apagar la notacion cientifica

options(scipen=10000) # Apaga la notacion cientifica

# toma la determinante de matrix "m1"
det(m1) # da practicamente 0. Eso es "malo" (la matriz no es invertible).

# Ejemplo 2: Multicolinearidad (que es diferente a Colinearidad Perfecta)
# Colinearidad perfecta, es precisamente eso, "perfecta"
# Multicolinearidad es la version mas ligera de "colinearidad perfecta".

# ejemplo
m2 = matrix(c(3,5,6,10), ncol = 2) # Define matrix "m"

m2 # llama a la matrix "m2" para verla

# Notan algo especial en esta matrix?

# el segundo vector de x2 es una "combinacion lineal" del primer
# vector: cual combinacion lineal?

# El resultado sera muy cercano a 0, y sera un numero muy
# pequeno, por lo que debemos apagar la notacion cientifica

options(scipen=10000) # Apaga la notacion cientifica

# toma la determinante de matrix "m"
det(m2) # mismo problema. |m2| = 0, o "la determinante de m2 es cero,
# por lo que m2 no es invertible"

# En ambos ejemplos ("m1" y "m2"), si la determinante es 0, la matrix no es
# invertible, y no podemos hacer la regresion.

# (1) En que casos REALES podemos tener problemas de
# colinearidad perfecta?

# (2) Por que es MUY COMUN tener problemas de colinearidad "imperfecta" (o "multicolinearidad")
# en ciencias sociales?

# OK, sigamos.

# Estimemos un modelo lineal multivariado.

# (1) Que mas podria ser importante para explicar/predecir represion?

colnames(dat) # "column names)

# "pop" (poblacion)?
# "rgdpch" (crecimiento economico)?
# "vdiss" (terrorismo)?

reg.multivariada = lm(repression ~ democracy + pop + vdiss, dat) # Completar

summary(reg.multivariada) # Hoy solo miraremos los coeficientes. Otro dia veremos el error std.

# Primero, calculemos y'
dat$repression.prima2 = predict.lm(reg.multivariada)

# Segundo, calculemos el error:
dat$error2 = reg.multivariada$residuals
# lo que predecimos (predict.lm(reg.multivariada)) y lo que observamos (dat$repression).

# Veamos...
head(dat)

# Graficando el error: Densidad
p_load(lattice) # Para graficos
densityplot(dat$error2)

# Ves un pastron o algo "inusual"?
plot(dat$repression.prima2, dat$error2)

# Funcion (que veremos mas adelante) para plotear diagnosticos.
plot(reg.multivariada)

# Summary ("Resumen")
summary(dat$error2)

# Pensemos en los coeficientes (los betas)

# (1) Como se leen los betas ahora que tenemos mas variables?
# (2) Que significa "constantes en el promedio"?

########################
# Mostrar resultados: tabla y grafico (coefplot)
########################

# Incertidumbre es el fantasma de este curso.
# Nunca sabemos si tenemos el "modelo verdadero".
# Es por esto que siempre hacemos mas de un modelo, y
# mostramos mas de un modelo en nuestro trabajo.

# Hagamos una tabla para mostrar nuestros resultados.

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

screenreg( # funcion
  list( # ponemos los dos modelos en una lista, que es otro objeto que R ocupa.
    reg.bivariada, # nuestro primer modelo
    reg.multivariada # nuestro segundo modelo
    )
  )

# (1) Como interpretamos esta tabla?

# Tambien podemos graficar nuestros coeficientes
p_load(coefplot)
multiplot(
  reg.bivariada, # nuestro primer modelo univariado
  reg.multivariada # nuestro segundo modelo multivariado
  )

# (1) Como interpretamos esto?

# Planteado para la proxima clase:
## (a) intervalos de confianza.
## (b) linea de cero (significancia estadistica)


###3#
# function to create a ternary plot of remote sensing data sources for ecological modeling
#
# started 3/7/17 cba
#####

library(ggtern)

# load the csv file
infile <- "~/src/aei-grad-school/scratch/satellite_scales.csv"
satData <- read.csv(file = infile, header = TRUE)

# transform the data to get a good distribution of values
satData["Frequency"] = 1/satData$Frequency
satData["sqrtFreq"] = sqrt(satData$Frequency)
satData["logExtent"] = log10(satData$Extent)
satData["lnExtent"] = log(satData$Extent)
satData["logScale"] = log10(satData$UseScale)
satData['lnScale'] = log(satData$UseScale)
satData["logFreq"] = log10(satData$Frequency)
satData['lnFreq'] = log(satData$Frequency)
satData["logSwath"] = log10(satData$Swath)
satData['lnSwath'] = log(satData$Swath)

# filter for data
gd <- which(satData$UseScale < 1e6)

# set up plot formats
xlab <- "Sampling Unit (m^2)"
xdata <- satData$logScale

ylab <- "Extent (km^2)"
ydata <- satData$logExtent

zlab <- "Frequency (1/days)"
zdata <- satData$Frequency

# set the data used for plot shapes
shapeValues = seq(length(unique(satData$EBV.Class))) + 20
EBV.Class <- satData$EBV.Class

# set the data used for plot colors
cbBase <- c("#000000", "#E69F00", "#56B4E9", "#009E73", "#F0E442", "#0072B2", "#D55E00", "#CC79A7")
cbPalette <- colorRampPalette(cbbBase)(length(unique(satData$EBV.Class)))

title <- "Satellite Scales"

# set up the basic plot function
base = ggtern(data = satData[gd,], aes(logScale, EBVScale, sqrtFreq))
base = base + geom_point(aes(fill = EBV.Class, shape = EBV.Class, size = 1)) +
  scale_shape_manual(values = shapeValues) +
  scale_fill_manual(values = cbBase) +
  theme_nomask() +
  labs(x = xlab, y = ylab, z = zlab) +
  theme_showarrows() +
  scale_x_log10()# + scale_y_log10()
base = base + theme_notitles() + theme_nolabels()
base

base = ggtern(data = satData[ad,], aes(logScale, EBVScale, sqrtFreq))
base = base + geom_point(aes(color = Sensor.Class), size = 10) +
  #geom_label_repel(aes(Frequency, UseScale, label = Satellite), segment.color = "black",
  #                 fontface = 'bold', color = 'black', box.padding = unit(0.4, "lines"),
  #                 point.padding = unit(0.7, "lines"), alpha = 0.8) +
  labs(x = xlab, y = ylab, z = zlab) +
  theme_showarrows() +
  scale_color_manual(values = cbBase) +
  theme_notitles() + theme_nolabels()
base


library(epimdr)
library(deSolve)

data(paili)
data(palymes)
data(pagiard)
data(pameasle)

ppp <- function(wk, x){
    require(plotrix)
    x = x[wk<53]
    wk = wk[wk<53]
    ses = sapply(split(x, wk), mean, na.rm = TRUE)
    sesdv = sapply(split(x, wk), sd, na.rm = TRUE)/sqrt(length(split(x, wk)))
    plotCI(x = c(1:52), y = ses, ui = ses+sesdv, li = ses-sesdv, xlab = "Week", ylab = "Incidence")
}

par(mfrow = c(2, 2))  #A four panel plot
ppp(paili[, "WEEK"], paili[, "PENNSYLVANIA"])
title("ILI mortality (1972-98)")
ppp(palymes[, "WEEK"], palymes[, "PENNSYLVANIA"])
title("Lymes (2006-14)")
ppp(pagiard[, "WEEK"], pagiard[, "PENNSYLVANIA"])
title("Giardia (2006-14)")
ppp(pameasle[, "WEEK"], pameasle[, "PENNSYLVANIA"])
title("Measles (1928-69)")

seirmod = function(t, y, parms) {
    S = y[1]
    E = y[2]
    I = y[3]
    R = y[4]

    mu = parms["mu"]
    N = parms["N"]
    beta = parms["beta"]
    sigma = parms["sigma"]
    gamma = parms["gamma"]

    dS = mu * (N - S) - beta * S * I/N
    dE = beta * S * I/N - (mu + sigma) * E
    dI = sigma * E - (mu + gamma) * I
    dR = gamma * I - mu * R
    res = c(dS, dE, dI, dR)
    list(res)
}

times  = seq(0, 10, by=1/120)
paras  = c(mu = 1/50, N = 1, beta =  1000,
     sigma = 365/8, gamma = 365/5)
start = c(S = 0.06, E = 0, I = 0.001, R = 0.939)

R0 = expression(sigma/(sigma + mu) * beta/(gamma + mu))
with(as.list(paras), eval(R0))

out = as.data.frame(ode(start, times, seirmod, paras))
par(mfrow = c(1,2))  #Two plots side by side
plot(times, out$I, ylab = "Prevalence",
     xlab = "Time", type = "l")
plot(out$S, out$I, ylab = "Prevalence",
     xlab = "Susceptible", type = "l")

seirmod2 = function(t, y, parms){
  S = y[1]
  E = y[2]
  I = y[3]
  R = y[4]
  with(as.list(parms),{
     dS = mu * (N  - S)  - beta0 * (1+beta1 *
        cos(2 * pi * t)) * S * I / N
     dE = beta0 * (1 + beta1 * cos(2*pi * t)) *
        S * I / N - (mu + sigma) * E
     dI = sigma * E - (mu + gamma) * I
     dR = gamma * I - mu * R
     res = c(dS, dE, dI, dR)
     list(res)
   })
}

times  = seq(0, 100, by=1/120)
paras  = c(mu = 1/50, N = 1, beta0 = 1000, beta1 = 0.2,
     sigma = 365/8, gamma = 365/5)
start = c(S = 0.06, E = 0, I = 0.001, R = 0.939)
out = as.data.frame(ode(start, times, seirmod2, paras))
par(mfrow = c(1,2)) #Side-by-side plot
plot(times, out$I, ylab="Infected", xlab="Time",
     xlim = c(90, 100), ylim = c(0,
     max(out$I[11001:12000])), type = "l")
plot(out$S[11001:12000], out$I[11001:12000],
     ylab = "Infected", xlab = "Susceptible", type = "l")

mu = paras["mu"]
N = paras["N"]
beta0 = paras["beta0"]
beta1 = paras["beta1"]
sigma = paras["sigma"]
gamma = paras["gamma"]
R0 = sigma/(sigma + mu) * beta0/(gamma + mu)
# Equilibria
Sstar = 1/R0
Istar = mu * (1 - 1/R0) * R0/beta0
Estar = (mu + gamma) * Istar/sigma
eq = list(S = Sstar, E = Estar, I = Istar)

dS = expression(mu * (N  - S)  - beta0 * S * I / N)
dE = expression(beta0 * S * I / N - (mu + sigma) * E)
dI = expression(sigma*E - (mu + gamma) * I)
#Elements of Jacobian
j11 = D(dS, "S");  j12 = D(dS, "E");  j13 = D(dS, "I")
j21 = D(dE, "S");  j22 = D(dE, "E");  j23 = D(dE, "I")
j31 = D(dI, "S");  j32 = D(dI, "E"); j33 = D(dI, "I")
#Jacobian
J = with(eq,
matrix(c(eval(j11),eval(j12),eval(j13),
   eval(j21),eval(j22), eval(j23),
   eval(j31),eval(j32), eval(j33)),
    nrow=3, byrow=TRUE))

round(eigen(J)$values, 3)
2 * pi/(Im(eigen(J)$values[2]))

times = seq(0, 100, by = 1/120)
start = c(S = 0.06, E = 0, I = 0.001, R = 0.939)
beta1 = seq(0,0.25, length=101)
#Matrix to store infecteds
Imat = matrix(NA, ncol = 12001, nrow = 101)
#Loop over beta1's
for(i in 1:101){
     paras  = c(mu = 1/50, N = 1, beta0 = 1000,
        beta1 = beta1[i], sigma = 365/8, gamma = 365/5)
     out = as.data.frame(ode(start, times,
        seirmod2, paras))
     Imat[i,] = out$I
}

sel = seq(7001, 12000, by = 120)
plot(NA, xlim = range(beta1), ylim = c(1E-7,
     max(Imat[,sel])), log = "y", xlab = "beta1",
     ylab = "prevalence")
for(i in 1:101){
       points(rep(beta1[i], length(sel)),
          Imat[i, sel], pch=20)
}

times = seq(0, 100000, by = 1/120)
start = c(S = 0.06, E = 0, I = 0.001, R = 0.939)
paras  = c(mu = 1/50, N = 1, beta0 = 1800, beta1=0.28,
     sigma = 35.84, gamma = 100)
out = as.data.frame(ode(start, times,seirmod2, paras))
sel = seq(7001, 12000000, by = 120)
par(mfrow = c(1,2))
plot(out$time[7001:13001], out$I[7001:13001],
     type = "l", xlab = "Year", ylab = "Prevalence")
plot(out$S[sel], out$I[sel], type = "p", xlab = "S",
     ylab = "I", log = "y", pch = 20, cex = 0.25)

times = seq(0, 100, by = 1/120)
start = c(S = 0.06, E = 0, I = 0.001, R = 0.939)
mu = seq(from = 0.005, to = 0.02, length = 101)
ImatF = ImatB = matrix(NA, ncol = 12001, nrow = 101)
for(i in 1:101){
     paras  = c(mu = mu[i], N = 1, beta0 = 2500,
          beta1=0.12, sigma = 365/8, gamma = 365/5)
      out = as.data.frame(ode(start, times, seirmod2,
           paras))
      ImatF[i,] = out$I
      start = c(S = out$S[12001], E = out$E[12001],
           I = out$I[12001], R = out$R[12001])
}
start = c(S = 0.06, E = 0, I = 0.001, R = 0.939)
for(i in 101:1){
     paras  = c(mu = mu[i], N = 1, beta0 = 2500,
          beta1 = 0.12, sigma = 365/8, gamma = 365/5)
     out = as.data.frame(ode(start, times, seirmod2,
          paras))
     ImatB[i,] = out$I
     start = c(S = out$S[12001], E = out$E[12001],
          I = out$I[12001], R = out$R[12001])
}
sel = seq(7001, 12000, by = 120)
par(mfrow = c(1,1))
     plot(NA, xlim = range(mu),  ylim = range(ImatF[,sel]),
          log = "y", xlab = "mu", ylab = "prevalence")
for(i in 1:101){
     points(rep(mu[i], dim(ImatF)[2]), ImatF[i, ],
          pch = 20, cex = 0.25)
     points(rep(mu[i], dim(ImatB)[2]), ImatB[i, ],
          pch = 20, cex = 0.25, col = 2)
 }


fizzbuzz <- function(num) {
   if (num %% 3  == 0 && num %% 5 == 0) {print("FizzBuzz")}
   else if (num %% 3 == 0) {print("Buzz")}
   else if (num %% 5 == 0) {print("Fizz")}
   else print(num)
}
sapply(1:100, fizzbuzz)


## Script en R empleado en la práctica 2 de Tipología y ciclo de vida de los datos.

## Luis Manuel Martin Guerra @UOC

## CARGA DE LAS LIBRERÍAS NECESARIAS
library(knitr)
library(nortest)
library(VIM)
library(ggplot2)

# Cargamos el dataset ya pre-procesado
gunpla <- read.table("/Users/manu/Documents/UOC - Ciencia de Datos/2 - Tipología y ciclo de vida de los datos/PRACTICA 2/gunpla_clean.csv", header=TRUE, sep=";", na.strings="NA", dec=",", strip.white=TRUE)

# Visualizamos los datos
summary(gunpla)

# Obtenemos las variables
var_class <-sapply(gunpla, class)

# Mostramos los tipos de datos
kable(data.frame(variable=names(var_class), tipo=as.vector(var_class)))

# Convertimos el Peso a numérico
gunpla[8]<-lapply(gunpla[8], as.numeric)

# Comprobamos que se ha realizado correctamente.
var_class <-sapply(gunpla, class)
kable(data.frame(variable=names(var_class), tipo=as.vector(var_class)))

# Buscamos los valores NULOS
sapply(gunpla, function(x)(sum(is.na(x)))) # NA counts

# Diagramos de caja de las variables estadísticas
Boxplot(Embalaje~Escala, data=gunpla, id.method="y")

Boxplot(Precio~Escala, data=gunpla, id.method="y")

Boxplot(Peso~Escala, data=gunpla, id.method="y")

# Eliminamos la columna Year
gunpla <- within(gunpla, {Year <- NULL })

# Ordenamos por orden de peso el dataset
gunpla <- with(gunpla, gunpla[order(Peso, decreasing=FALSE), ])

# Cálculo de los valores aproximados basados en los k-vecinos.
gunpla$Embalaje <- kNN(gunpla)$Embalaje

sapply(gunpla, function(x)(sum(is.na(x)))) # NA counts

# Test Shapiro-Wilk para ver la normalización
shapiro.test(gunpla$Peso)

shapiro.test(gunpla$Precio)

shapiro.test(gunpla$Embalaje)

# Creamos la matriz de correlación

cor(gunpla[,c("Embalaje","Factor_Escala","Peso","Precio")], method="spearman", use="complete")

# Creamos un modelo de regresión
modelo_gunpla <- lm(Precio~Embalaje+Escala+Peso, data=gunpla)
summary(modelo_gunpla)

# Creamos un dataframe para probar el modelo
test_gundam <-data.frame(Nombre="Test", Factor_Escala=4,Escala="1/144",Detalle="High Grade", Serie="Gundam SEED", Embalaje=1600, Peso =140, Precio=5.3)

# Ponemos a prueba el modelo
predict(modelo_gunpla,test_gundam)

# Diagramas de dispersión de la escala, peso, embalaje y precio
ggplot(gunpla, aes(Escala, Peso, color=Escala))+geom_point()

ggplot(gunpla, aes(Precio, Peso, color=Escala))+geom_point()

ggplot(gunpla, aes(Embalaje, Precio, color=Escala))+geom_point()

# Gráfica de barras con las escalas y el nivel de detalle.
with(gunpla, Barplot(Detalle, by=Escala, style="divided", legend.pos="topright", xlab="Detalle", ylab="Frequency"))


# 4. faza: Analiza podatkov

tabelazaanalizo <- tabela2 %>%
  filter(regija=="SLOVENIJA")
samopike <- ggplot(tabelazaanalizo, aes(x=leto, y=vrednost)) + geom_point()
model <- lm(vrednost ~ leto, data=tabelazaanalizo)
napoved <- ggplot(tabelazaanalizo, aes(x=leto, y=vrednost)) + geom_point() +
          geom_smooth(method=lm, formula=y~x) +
          ylab("Dobavljena voda na prebivalca v m^3")

prihodnjaleta <- data.frame(leto=c(2020:2025))
predict(model, prihodnjaleta)
napoved1 <- prihodnjaleta %>% mutate(vrednost=predict(model, prihodnjaleta))
napoved1$vrednost <- round(napoved1$vrednost, digit=1)
napoved2 <- rbind(tabelazaanalizo[,-1], napoved1)

izrisnapovedi <- ggplot(napoved2, aes(x=leto, y=vrednost)) +
  geom_point(shape=1) +
  geom_smooth(method=lm, formula=y~x) +
  geom_point(data=napoved1, aes(x=leto, y=vrednost), color="red", size=2) +
  xlab("Leto") +
  ylab("Dobavljena voda v m^3 na prebivalca")


library(bitops)
bitAnd(35, 42)          # 34
bitOr(35, 42)           # 43
bitXor(35, 42)          # 9
bitFlip(35, bitWidth=8) # 220
bitShiftL(35, 1)        # 70
bitShiftR(35, 1)        # 17
# Note that no bit rotation is provided in this package


library(ProjectTemplate)
load.project()

# Cleans the American League (AL) and National League (NL) data scraped from
# ESPN's MLB Grid
AL_cleaned <- clean_ESPN_grid_data(AL.standings, league = "AL")
NL_cleaned <- clean_ESPN_grid_data(NL.standings, league = "NL")

# Fits the Bradley-Terry models for both leagues
set.seed(42)
AL_model <- BTm(cbind(Wins, Losses), Team, Opponent, ~ `team_`,
                id = "team_", data = AL_cleaned$standings)
NL_model <- BTm(cbind(Wins, Losses), Team, Opponent, ~ `team_`,
                id = "team_", data = NL_cleaned$standings)

# Extracts team abilities for each league
AL_abilities <- data.frame(BTabilities(AL_model))$ability
names(AL_abilities) <- AL_cleaned$teams

NL_abilities <- data.frame(BTabilities(NL_model))$ability
names(NL_abilities) <- NL_cleaned$teams

# Tables of team abilities
print(ascii(as.data.frame(BTabilities(AL_model)), digits = 3), type = "org")
print(ascii(as.data.frame(BTabilities(NL_model)), digits = 3), type = "org")

# Bar graphs of the team abilities for each league
barplot(sort(AL_abilities), main = "American League Team Abilities")
barplot(sort(NL_abilities), main = "National League Team Abilities")

# Here, we create a heatmap of probabilities winning for each team pairing.
# To do so, we create a grid of the probabilities.
# Given that the inverse logit of 0 is 0.5, the probability that team beats
# itself is estimated as 0.5. To avoid this confusing situation, we set these
# probabilities to 0. The point is that these events can never happen unless
# you play for Houston or have A-Rod on your team.
AL_probs <- outer(AL_abilities, AL_abilities, prob_BT)
diag(AL_probs) <- 0
AL_probs <- melt(AL_probs)

NL_probs <- outer(NL_abilities, NL_abilities, prob_BT)
diag(NL_probs) <- 0
NL_probs <- melt(NL_probs)

colnames(AL_probs) <- colnames(NL_probs) <- c("Team", "Opponent", "Probability")

# Plots of heatmaps of the probabilties of each team matchup
heatmap_MLB_grid_probs(AL_probs, title = "American League Matchup Probabilities")
heatmap_MLB_grid_probs(NL_probs, title = "National League Matchup Probabilities")

# American League probabilities of matchups of best, worst, and middle ranked teams

# Probability that the top-ranked AL team, Tampa Bay, beats each team
TB_probs <- subset(AL_probs, Team == "TB" & Opponent != "TB")
p <- ggplot(TB_probs, aes(x = Opponent)) + geom_bar(aes(weight = Probability))
p <- p + ylab("Probability") + theme_bw()
p <- p + geom_hline(aes(yintercept = 0.5), color = "red")
p + ggtitle("Probability of Tampa Bay Beating Other American League Opponents")

# Probability that Oakland beats each team
# Oakland is ranked in the middle according to the BT model
OAK_probs <- subset(AL_probs, Team == "OAK" & Opponent != "OAK")
p <- ggplot(OAK_probs, aes(x = Opponent)) + geom_bar(aes(weight = Probability))
p <- p + ylab("Probability") + theme_bw()
p <- p + geom_hline(aes(yintercept = 0.5), color = "red")
p + ggtitle("Probability of Oakland Beating Other American League Opponents")

# Probability that the worst-ranked AL team, Houston, beats each team
HOU_probs <- subset(AL_probs, Team == "HOU" & Opponent != "HOU")
p <- ggplot(HOU_probs, aes(x = Opponent)) + geom_bar(aes(weight = Probability))
p <- p + ylab("Probability") + theme_bw()
p <- p + geom_hline(aes(yintercept = 0.5), color = "red")
p + ggtitle("Probability of Houston Beating Other American League Opponents")

# National League probabilities of matchups of best, worst, and middle ranked teams

# Probability that the top-ranked NL team, Atlanta, beats each team
ATL_probs <- subset(NL_probs, Team == "ATL" & Opponent != "ATL")
p <- ggplot(ATL_probs, aes(x = Opponent)) + geom_bar(aes(weight = Probability))
p <- p + ylab("Probability") + theme_bw()
p <- p + geom_hline(aes(yintercept = 0.5), color = "red")
p + ggtitle("Probability of Atlanta Beating Other National League Opponents")

# Probability that Washington beats each team
# Washington is ranked in the middle according to the BT model
WSH_probs <- subset(NL_probs, Team == "WSH" & Opponent != "WSH")
p <- ggplot(WSH_probs, aes(x = Opponent)) + geom_bar(aes(weight = Probability))
p <- p + ylab("Probability") + theme_bw()
p <- p + geom_hline(aes(yintercept = 0.5), color = "red")
p + ggtitle("Probability of Washington Beating Other National League Opponents")

# Probability that the worst-ranked NL team, Miami, beats each team
MIA_probs <- subset(NL_probs, Team == "MIA" & Opponent != "MIA")
p <- ggplot(MIA_probs, aes(x = Opponent)) + geom_bar(aes(weight = Probability))
p <- p + ylab("Probability") + theme_bw()
p <- p + geom_hline(aes(yintercept = 0.5), color = "red")
p + ggtitle("Probability of Miami Beating Other National League Opponents")


# 4. faza: Napredna analiza podatkov

library(ggalt)
library(dplyr)

source("uvoz/uvoz.r", encoding="UTF-8")

###################### RAZVRŠČANJE V SKUPINE ###########################

tabela3.norm <- tabela3[c(2:7)] %>% as.matrix()%>% scale()
rownames(tabela3.norm) <- tabela3$dejanje

#dendogramom

dendrogram  <- dist(tabela3.norm) %>% hclust(method = "ward.D")
#plot(dendrogram, hang=-0.5, cex=0.01)

######### v koliko skupin je treba razdeliti?

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 = 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()
}

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()
}

kolena <- diagram.kolena(r)

## kolena so 2, 3, 5

### dendogram razrežemo na 5 delov

plot(dendrogram, hang=-0.5, cex=0.1)
rect.hclust(dendrogram,k=5,border="red")
p <- cutree(dendrogram, k=5)

## METODA K-TIH VODITELJEV

skupine = tabela3.norm[, -1] %>%
  kmeans(centers = 3) %>%
  getElement("cluster") %>%
  as.ordered()

#DIAGRAM

# naredim tabelo, s katero lahko naredimo diagram v 2d

razdalje <- tabela3.norm[, -1] %>% dist()
dejanja = tabela3[, 1] %>% unlist()

tabela3.xy =
  as_tibble(razdalje %>% cmdscale(k = 2)) %>%
  bind_cols(dejanja) %>%
  dplyr:: select(dejanje = ...3, x = V1, y = V2)

# poskusimo narisati diagram

diagram.skupine = function(tabela, oznake, skupine, k) {

  podatki = tabela %>%
    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
}

diagram3 <- diagram.skupine(tabela3.xy, tabela3$dejanje, skupine, 3)

## definicija funkcije za shiny

izris <- function(stevilo){

  skupine = tabela3.norm[, -1] %>%
    kmeans(centers = stevilo) %>%
    getElement("cluster") %>%
    as.ordered()

  tabela.3 = tabela3 %>%
    bind_cols(skupine) %>%
    dplyr:: rename(skupina = ...8)

  podatki <- pivot_longer(tabela.3,
                          cols = colnames(tabela3)[-1],
                          names_to = "starost",
                          values_to = "stevilo")

  podatki$starost <- parse_factor(podatki[["starost"]], levels = c("do 20 let", "od 21 do 30 let", "od 31 do 40 let", "od 41 do 50 let", "od 51 do 60 let", "nad 60 let"))

  g <- podatki%>%  group_by(starost) %>%
    ggplot(
      mapping = aes(x = starost, y = stevilo, fill = dejanje)
    )  +
    labs(x = "Starostne skupine", y = "Število obsojenih",
         title = "Število obsojenih po starostnih skupinah")+
    geom_col() +
    theme(legend.position = "None",
      axis.text.x = element_text(angle = 45, vjust = 0.5),
      axis.title.x = element_text(vjust = 0)
    )+
    facet_wrap(.~ skupina,ncol = 5)

  print(g)
}

##########################   NAPOVEDNI MODEL   ###########################

library(ggplot2)
library(GGally)
library(dplyr)

ggpairs(tabela_r %>% dplyr::select(obsojeni, zadovoljstvo, revscina, stanovanje))
#upoštevala bom vse tri parametre

# kasnjene ugotovila da je bolje če upoštevam tudi leta in regije

podatki.n <- tabela_r

#  prečno preverjanje:

napaka <- function(k, formula){

  set.seed(1)
  n <- nrow(podatki.n)

  # v je vektor premešanih števim od 1 do n:
  v <-sample(1:n)
  #razrez vzame vektor 1:n in ga razreže v k delov (1:n elementom da cifre od 1 do k)
  razrez <- cut(1:n, k, labels=FALSE)
  # vektor v razbije glede na razrez
  razbitje <- split(v, razrez)
  #naredi n dolg vektor elementov 0
  pp.napovedi <- rep(0, n)

  for (i in (1:k)){
    #ucni podatki:
    ucenje <- podatki.n[-razbitje[[i]],]
    #testni podatki:
    test <- podatki.n[razbitje[[i]],]
    model <- lm(data=ucenje, formula=formula)
    #napovemo za testne podatke
    napovedi<- predict(model, newdata=test)
    pp.napovedi[razbitje[[i]]] <- napovedi
  }

    napaka = mean((pp.napovedi - podatki.n$obsojeni)^2)

    return (napaka)

}

napaka.ln <- napaka(3, obsojeni ~ .)

# puskusimo še z naključnimi gozdovi

library(ranger)

napaka.ng <- function(k, formula){

  set.seed(1)
  n <- nrow(podatki.n)

  v <-sample(1:n)
  razrez <- cut(1:n, k, labels=FALSE)
  razbitje <- split(v, razrez)
  pp.napovedi <- rep(0, n)

  for (i in (1:k)){
    ucenje <- podatki.n[-razbitje[[i]],]
    test <- podatki.n[razbitje[[i]],]
    model <- ranger(formula, data=ucenje)
    napovedi<- predict(model, test)$predictions
    pp.napovedi[razbitje[[i]]] <- napovedi
  }

  napaka = mean((pp.napovedi - podatki.n$obsojeni)^2)

  return (napaka)

}

napaka.ng <- napaka.ng(3, obsojeni ~ .)

####### MOČ POSAMEZNE SPREMENLJIVKE

library(iml)

# podatki ki so uporabljeni zastrojno učenej zgoraj: podatki.n

model <- lm(formula=obsojeni~., data=podatki.n)

X = podatki.n %>% dplyr:: select(!obsojeni)

pfun = function(model, newdata) {
  predict(model,newdata = newdata)
}

lm.pred = Predictor$new(model= model, data = X, y = podatki.n$obsojeni, predict.function = pfun)

lm.moci = FeatureImp$new(lm.pred, loss = "mse")

moc <- plot(lm.moci)


shift <- function(x, n, invert=FALSE, default=NA){
  stopifnot(length(x)>=n)
  if(n==0){
    return(x)
  }
  n <- ifelse(invert, n*(-1), n)
  if(n<0){
    n <- abs(n)
    forward=FALSE
  }else{
    forward=TRUE
  }
  if(forward){
    return(c(rep(default, n), x[seq_len(length(x)-n)]))
  }
  if(!forward){
    return(c(x[seq_len(length(x)-n)+n], rep(default, n)))
  }
}

denoise_step <- function(x){
  return(pmax(x, shift(x, 1), na.rm = TRUE))
}

denoise <- function(x){
  return(denoise_step(denoise_step(denoise_step(x))))
}

data <- list()
legends <- list()

basepath <- "../../data/v2/sgd2/";

data[[1]] <- read.csv(file.path(basepath, "s0.001-mu-0.3-threads30/lda-progress-mongo-s0.001-mu-0.3-5326.csv"));
legends[[1]] <- "momentum=-0.3";

data[[2]] <- read.csv(file.path(basepath, "s0.001-mu+0.0-threads30/lda-progress-mongo-s0.001-mu0-5327.csv"));
legends[[2]] <- "momentum=0.0";

data[[3]] <- read.csv(file.path(basepath, "s0.001-mu+0.3-threads30/lda-progress-mongo-s0.001-mu0.3-5314.csv"));
legends[[3]] <- "momentum=0.3";

data[[4]] <- read.csv(file.path(basepath, "s0.001-mu+0.6-threads30/lda-progress-mongo-s0.001-mu0.6-5327.csv"));
legends[[4]] <- "momentum=0.6";

# data[[5]] <- read.csv(file.path(basepath, "0.999-1/lda-progress-mongo-0.999-1-5101.csv"));
# legends[[5]] <- "b1=0.999, b2=1";

# data[[6]] <- read.csv(file.path(basepath, "30-threads/lda-progress-mongo-2750.csv"));
# legends[[6]] <- "30 threads";

pdf("../../figures/v2/expt-7-30-threads-momentum-denoise.pdf")

plot(data[[1]]$time, data[[1]]$objective, ylim=c(-48000, -39000), type="n", xlab="Runtime (seconds)", ylab="ELBo", main="LDA (SGD, 30 threads, step size 0.001)");

colors <- rainbow(6)

for (i in 1:4){
    lines(data[[i]]$time, denoise(data[[i]]$objective), col=colors[i])
}

legend("bottomright", legend=legends, col=colors, lty=1)

dev.off()


suppressMessages(library(float))
suppressMessages(library(kazaam))
suppressMessages(library(clustrgame))
comm.set.seed(1234, diff=TRUE)

# rnorm_fun = stats::rnorm
rnorm_fun = curand::rnorm

.pbd_env$SPMD.CT$print.quiet = TRUE

m = 3e5
m.local = kazaam:::get_local_dim(m)
n = 250
k = 3
maxiter = 2

centers = c(0, 2, 10)

generator = function(m, n, centers)
{
  centers_rows = sample(3, size=m, replace=TRUE)
  data = matrix(0.0, m, n)
  for (i in 1:length(centers))
  {
    rows = which(centers_rows == i)
    data[rows, ] = rnorm_fun(length(rows)*n, mean=centers[i])
  }

  data
}

generator = compiler::cmpfun(generator)
t_gen = system.time(data <- generator(m.local, n, centers))
comm.cat("data gen (dbl):   ", t_gen[3], "\n")

x = shaq(data, m, n, checks=FALSE)
s = shaq(fl(data), m, n, checks=FALSE)

t_kazaam = system.time(out1 <- kazaam::km(x, k=k, maxiter=maxiter))
comm.cat("kazaam (dbl):     ", t_kazaam[3], "\n")
t_clustrgame = system.time(out2 <- clustrgame::km_game(x, k=k, maxiter=maxiter))
comm.cat("clustrgame (dbl): ", t_clustrgame[3], "\n")
t_clustrgamef = system.time(out3 <- clustrgame::km_game(s, k=k, maxiter=maxiter))
comm.cat("clustrgame (flt): ", t_clustrgamef[3], "\n")

comm.print(c(out1$iterations, out2$iterations, out3$iterations))

finalize()


library(rstan)

all_dat = readRDS('../data/all_melt.RDS')
dat = all_dat[,c(1,2,3,7,8, 4)]

tots = aggregate(value ~ date + class, dat, sum)

int = dat[dat$int==TRUE,c('class', 'date', 'month', 'year', 'value' )]
dat_org = merge(int, tots, by = c('date', 'class'))
colnames(dat_org)[5:6] = c('int', 'total')
dat_org = data.frame(dat_org, nint = dat_org$total - dat_org$int)
levels(dat_org$class) <- c('GR', 'PD', 'TT')

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

gr_dat = dat_org[which(dat_org$class == 'GR'),]
gr_dat = gr_dat[order(gr_dat$date),]
gr_dat$nint_p = gr_dat$nint/gr_dat$total

pd_dat = dat_org[which(dat_org$class == 'PD'),]
pd_dat = pd_dat[order(pd_dat$date),]
pd_dat$nint_p = pd_dat$nint/pd_dat$total

tt_dat = dat_org[which(dat_org$class == 'TT'),]
tt_dat = tt_dat[order(tt_dat$date),]
tt_dat$nint_p = tt_dat$nint/tt_dat$total

date  = tt_dat$date
month = tt_dat$month
year  = tt_dat$year
T     = length(date)

X <- matrix(0, nrow=length(month), ncol=length(unique(month)))
X[cbind(seq_along(month), month)] <- 1

all <- list(T = T,
            N_years = length(unique(year)),
            N_months = length(unique(month)),
            K = 12,
            date = date,
            month = month,
            year  = year-2000+1,
            y_tt  = tt_dat$int,
            N_tt  = tt_dat$total,
            y_gr  = gr_dat$int,
            N_gr  = gr_dat$total,
            y_pd  = pd_dat$int,
            N_pd  = pd_dat$total)

fit_m1 <- stan(file    = 'ecolog_m1.stan',
               data    = all,
               iter    = 200,
               chains  = 1,
               control = list(max_treedepth=12))
post_m1   <- extract(fit_m1)

plot(fit_m1, pars=c('alpha_tt', 'alpha_pd', 'alpha_gr'))
plot(fit_m1, pars=paste0('beta_t[', seq(1, T), ']'))
plot(fit_m1, pars=paste0('beta_tt[', seq(1, 12), ']'))
plot(fit_m1, pars=paste0('beta_pd[', seq(1, 12), ']'))
plot(fit_m1, pars=paste0('beta_gr[', seq(1, 12), ']'))

plot(date, colMeans(post[['beta_t']]), type='l')
plot(month,colMeans(post[['beta_t']]))
acf(colMeans(post[['beta_t']]))

pdf(file='figures/ecolog_m1.pdf', height=10, width=12)
par(mfrow=c(1,1))
plot(date, tt$y/tt$total, type='l')
lines(date, colMeans(post_m1[['theta_tt']]), col='blue')

plot(date, pd$y/pd$total, type='l')
lines(date, colMeans(post_m1[['theta_pd']]), col='blue')

plot(date, gr$y/gr$total, type='l')
lines(date, colMeans(post_m1[['theta_gr']]), col='blue')
dev.off()

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

fit_m2 <- stan(file = 'ecolog_m2.stan', data = all,
            iter = 200, chains = 1, control = list(max_treedepth=13))
post_m2   <- extract(fit_m2)

plot(fit_m2, pars=c('alpha_tt', 'alpha_pd', 'alpha_gr'))
plot(fit_m2, pars=c('alpha_tt1', 'alpha_pd1', 'alpha_gr1'))

plot(fit_m2, pars=paste0('sigma[', seq(1, 3), ']'))
plot(fit_m2, pars=paste0('beta_tt[', seq(1, 12), ']'))
plot(fit_m2, pars=paste0('beta_pd[', seq(1, 12), ']'))
plot(fit_m2, pars=paste0('beta_gr[', seq(1, 12), ']'))

pdf(file='figures/ecolog_m2.pdf', height=10, width=12)
par(mfrow=c(1,1))
plot(date, tt$y/tt$total, type='l')
lines(date, colMeans(post_m2[['theta_tt']]), col='blue')

plot(date, pd$y/pd$total, type='l')
lines(date, colMeans(post_m2[['theta_pd']]), col='blue')

plot(date, gr$y/gr$total, type='l')
lines(date, colMeans(post_m2[['theta_gr']]), col='blue')
dev.off()

#
# ######################################################################################################################################
# gr_dat = dat_org[which(dat_org$class == 'GR'),]
# gr_dat = gr_dat[order(gr_dat$date),]
# gr_dat$nint_p = gr_dat$nint/gr_dat$total
#
# date  = gr_dat$date
# month = gr_dat$month
# year  = gr_dat$year
# T     = length(date)
#
#
# X <- matrix(0, nrow=length(month), ncol=length(unique(month)))
# X[cbind(seq_along(month), month)] <- 1
#
# # y = matrix(cbind(gr_dat$int, gr_dat$total-gr_dat$int), ncol=2)
# # X = matrix(rep(1, nrow(y)))
#
# gr <- list(T = T,
#            K = 12,
#            date = date,
#            month = month,
#            year  = year,
#            y     = gr_dat$int,
#            total = gr_dat$total)
#
# fit_gr <- stan(file = 'gr_bin_mes.stan', data = gr,
#                iter = 100, chains = 1, control = list(max_treedepth=12, adapt_delta=0.9))
#
# fit  <- fit_gr
# post <- extract(fit_gr)
#
# pdf(file='figures/gr_ar_bin.pdf', height=10, width=12)
# plot(fit)
# plot(fit, pars=c('sigma'))
# plot(fit, pars=c('alpha'))
# plot(fit, pars=c('beta[1]', 'beta[2]','beta[3]','beta[4]','beta[5]',
#                  'beta[6]','beta[7]','beta[8]','beta[9]','beta[10]',
#                  'beta[11]','beta[12]'))
#
# # plot(post[['sigma']], type='l')
# theta = post[['theta']]
#
# library(boot)
# plot(date, 1-gr_dat$nint_p, type='l')
# lines(date, colMeans(post[['theta']]), col='blue')
# dev.off()
#
# ######################################################################################################################################
#
# pd_dat = dat_org[which(dat_org$class == 'PD'),]
# pd_dat = pd_dat[order(pd_dat$date),]
# pd_dat$nint_p = pd_dat$nint/pd_dat$total
#
# date  = pd_dat$date
# month = pd_dat$month
# year  = pd_dat$year
# T     = length(date)
#
#
# X <- matrix(0, nrow=length(month), ncol=length(unique(month)))
# X[cbind(seq_along(month), month)] <- 1
#
# # y = matrix(cbind(gr_dat$int, gr_dat$total-gr_dat$int), ncol=2)
# # X = matrix(rep(1, nrow(y)))
#
# gr <- list(T = T,
#            K = 12,
#            date = date,
#            month = month,
#            year  = year,
#            y     = gr_dat$int,
#            total = gr_dat$total)
#
# pd <- list(T = T,
#            K = 12,
#            date = date,
#            month = month,
#            year  = year,
#            y     = pd_dat$int,
#            total = pd_dat$total)
#
# fit <- stan(file = 'gr_bin_mes.stan', data = pd,
#             iter = 200, chains = 1, control = list(max_treedepth=12))
# post <- extract(fit)
# fit_pd <- fit
#
# pdf(file='figures/pd_ar_bin.pdf', height=10, width=12)
# # plot(fit, pars=c('sigma'))
# # plot(fit, pars=c('beta_t'))
# plot(fit_pd, pars=c('alpha'))
# plot(fit_pd, pars=c('beta[1]', 'beta[2]','beta[3]','beta[4]','beta[5]',
#                     'beta[6]','beta[7]','beta[8]','beta[9]','beta[10]',
#                     'beta[11]','beta[12]'))
#
# # plot(post[['sigma']], type='l')
# theta = post[['theta']]
#
# # library(boot)
# plot(date, pd$y/pd$total, type='l')
# lines(date, colMeans(post[['theta']]), col='blue')
# dev.off()
#
# ######################################################################################################################################
#
# tt_dat = dat_org[which(dat_org$class == 'TT'),]
# tt_dat = tt_dat[order(tt_dat$date),]
# tt_dat$nint_p = tt_dat$nint/tt_dat$total
#
# date  = tt_dat$date
# month = tt_dat$month
# year  = tt_dat$year
# T     = length(date)
#
#
# X <- matrix(0, nrow=length(month), ncol=length(unique(month)))
# X[cbind(seq_along(month), month)] <- 1
#
# tt <- list(T = T,
#            K = 12,
#            date = date,
#            month = month,
#            year  = year,
#            y     = tt_dat$int,
#            total = tt_dat$total)
#
# fit <- stan(file = 'gr_bin_mes.stan', data = tt,
#             iter = 200, chains = 1, control = list(max_treedepth=12))
# fit_tt <- fit
# post   <- extract(fit_tt)
#
# pdf(file='figures/tt_ar_bin.pdf', height=10, width=12)
# # plot(fit, pars=c('sigma'))
# # plot(fit, pars=c('beta_t'))
# plot(fit_tt, pars=c('alpha'))
# plot(fit_tt, pars=c('beta[1]', 'beta[2]','beta[3]','beta[4]','beta[5]',
#                     'beta[6]','beta[7]','beta[8]','beta[9]','beta[10]',
#                     'beta[11]','beta[12]'))
#
# # plot(post[['sigma']], type='l')
# theta = post[['theta']]
#
# # library(boot)
# plot(date, tt$y/tt$total, type='l')
# lines(date, colMeans(post[['theta']]), col='blue')
# dev.off()
#


file<-file.path(data.path,'sms.psv')
zz <- file(file, "rb")
nParm<-readBin(zz, integer(), 1)
parm<-t(matrix(readBin(zz, numeric(), 1E6),nrow=nParm))

summary(parm[,1])

plot(parm[,12])

cor(parm,parm)

#test for normality, lower p value indicates larger deviation from normal distribution
a<-apply(parm,2,shapiro.test)
p.val<-rep(1,length(a))
for (i in (1:length(a))) p.val[i]<-unlist(a[[i]][2])
p.val<-data.frame(nr=1:length(a),p.val)

index<-order(p.val$p.val)
p.val<-p.val[index,]

dev<-"print"
dev<-"screen"
nox<-5; noy<-5;
noxy<-nox*noy

newplot(dev,nox,noy);
par(mar=c(3,4,3,2))

i<-0

for (n in (1:25)) {
  if (i==noxy) {newplot(dev,nox,noy);par(mar=c(3,4,3,2)); i<-0 }
hist(parm[,p.val[n,1]],main=paste("parameter:",p.val[n,1]),xlab="")
  i<-i+1
}

for (n in (26:50)) {
  if (i==noxy) {newplot(dev,nox,noy);par(mar=c(3,4,3,2)); i<-0 }
hist(parm[,p.val[n,1]],main=paste("parameter:",p.val[n,1]),xlab="")
  i<-i+1
}


#install packages ## ** block -> ctrl+enter
install.packages("stringr")
#string data / str_length(), str_sub()
install.packages("KoNLP") #Korean
install.packages(("doBy"))
#data / summaryBy(), orderBy(), sampleBy()
install.packages(("sqldf"))
install.packages("plyr")
#data / adply(), ddply(), mdply() /merge, add, deduct
install.packages("reshape2")
#data / melt(), cast()

# =======================================================
# 01. 다음과 같은 벡터 객체를 생성하시오.
# =======================================================

#조건1. Vec1 벡터 변수를 만들고, "R" 문자가 5회 반복되도록 하시오.
vec1<-rep("R", 5)

#조건2. Vec2 벡터 변수에 1~10까지 3 간격으로 연속된 정수를 만드시오
vec2 <- seq(1, 10, by=3)

#조건3. Vec3에는 1~10까지 3 간격으로 연속된 정수가 3회 반복되도록 만드시오.
vec3 <- rep(vec2, 3)

#조건4. Vec4에는 Vec2 ~ Vec3가 모두 포함되는 벡터를 만드시오
vec4 <- append(vec2, vec3)

#조건5. 25 ~ -15까지 5 간격으로 벡터 생성 (seq 사용)
vec5 <- seq(25,-15, by=-5)
vec5
#조건6. Vec4에서 홀수번째 값들만 선택하여 Vec5에 할당하시오
vec6 <- vec5[seq(1, length(vec5), by=2)]
vec6

# =======================================================
# 02. 다음과 같은 벡터를 칼럼으로 갖는 데이터프레임을 생성하시오
# =======================================================

# 다음---------------------------------------------------
name	<- c('최민수', '유관수', '이순신', '김유신', '홍길동')
age		<- c(55, 45, 45, 53, 15)
gender	<- c(1, 2, 1, 1, 1)
job		<- c('연예인', '주부', '군인', '직장인', '학생')
sat		<- c(3, 4, 2, 5, 5)
grade	<- c('C', 'C', 'A', 'D', 'A')
total	<- c(44.4, 28.5, 43.5, NA, 27.1)

#조건1. 위 7개의 벡터를 칼럼으로 갖는 user 데이터 프레임 생성
user <- data.frame(name, age, gender, job, sat, grade, total)
user

#조건2. gender 변수를 이용하여 히스토그램 그리기
hist(gender)

#조건3. user에서 짝수행만 선택해서 user2에 넣기
user2 <- user[seq(1, nrow(user), by=2)]
user2

# =======================================================
# 03. Data를 대상으로 apply()를 적용하여 행/열 방향으로 조건에 맞게 통계량을 구하시오.
# =======================================================
# 다음---------------------------------------------------
kor	<- c(90, 85, 90)
eng	<- c(70, 85, 75)
mat	<- c(86, 92, 88)

#조건1. 3개의 과목점수를 이용하여 데이터프레임(Data)를 생성한다.
score <- data.frame(kor, eng, mat)
score

#조건2. 행/열 방향으로 max()함수를 적용하여 최댓값 구하기
score$max <- apply(score, 1, max)
apply(score, 2, max)

#조건3. 행/열 방향으로 mean()함수를 적용하여 평균 구하기(소숫점 2자리 표현)
score$mean <- apply(score, 1, mean)
apply(score, 2, mean)

#조건4. 행 단위 분산과 표준편차 구하기
apply(score, 2, sd)
apply(score, 2, var)

# =======================================================
# 04. 다음의 Data2 객체를 대상으로 정규표현식을 적용하여 문자열을 처리하시오.
# =======================================================
# 다음---------------------------------------------------
Data2 <- c('2017-02-05 수입3000원', '2017-02-06 수입4500원', '2017-02-07 수입2500원')
library(stringr) #add
# lib stringR

#조건1. 일자별 수입을 다음과 같이 출력하시오. #str_extract_all
str_extract_all(Data2, '[0-9]+원')
Data2

#조건2. 위 벡터에서 연속하여 2개 이상 나오는 모든 숫자를 제거하시오
str_replace_all(Data2, "[0-9][0-9]", " ")

#조건3. 위 벡터에서 -를 /로 치환하시오 #str_replace_all
str_replace_all(Data2, "-", "/")

#조건4. 모든 원소를 쉼표(,)에 의해서 하나의 문자열로 합치시오 #paste
edit <- str_replace_all(Data2, " ", "")
paste(edit, collapse = "")


# Compute likelihood of trees according to generative model and parameters
# author: Alberto Lumbreras
###########################################################################

library(dplyr)
library(data.table)
library(igraph)
# Compute degrees only once for all trees (3-dimensional array: node, time, tree)
#all.degrees <- list()
#for (i in 1:length(trees)){
#  parents <- get.edgelist(trees[[i]])[,2]
#  size <- length(parents)+1
#  all.degrees[[i]] <- t(sapply(2:size, function(t) tabulate(parents[1:t], nbins=size)))
#}

likelihood.Gomez2013 <- function(trees, alpha=1, beta = 1, tau = 0.75){
  # Compute the likelihood of the whole set of trees
  # Arguments:
  #   trees: observed list of trees
  #   alpha.root, alpha.c, beta.root: parameters of the model
  like <- 0
  for (i in 1:length(trees)){
    g <- trees[[i]]
    parents <- get.edgelist(g)[,2] # parents vector

    # skip root and first post
    for(t in 2:length(parents)){
      b <- rep(0,t)
      b[1] <- beta
      lags <- t:1
      popularities <- 1 + tabulate(parents[1:(t-1)], nbins=t)
      popularities[1] <- popularities[1] - 1 # root has no parent
      probs <- alpha*popularities + b + tau^lags
      probs <- probs/sum(probs)
      like <- like + log(probs[parents[t]])
    }
  }
  like
}

# Likelihood computation using the dataframe
likelihood.post <- function(row, alpha, beta, tau){
  log(alpha * row['popularity'] + beta*(row['parent']==1) + tau^row['lag']) -
  log(2*alpha*(row['t']-1/2)   + beta + tau*(tau^row['t']-1)/(tau-1))
  # -1/2 because root has at least degree 1 (to follow Gomez 2013)
  # if the root starts with degree 0, then it should be:
  # log(2*alpha*(row['t']-1)   + beta + tau*(tau^row['t']-1)/(tau-1))
}

likelihood.Gomez2013.df <- function(df.trees, alpha = 1, beta = 1, tau = 0.75){
  # Likelihood using dataframe instead of list of trees
  sum(apply(df.trees, 1, likelihood.post, alpha, beta, tau))
}

likelihood.Lumbreras2016.users <- function(df.trees, users, alpha, beta, tau){
  # Compute the likelihood of the user posts given the parameters alpha, beta and tau
  mask <- df.trees$user %in% users
  sum(apply(df.trees[mask,], 1, likelihood.post, alpha, beta, tau))
}

if(FALSE){

  alpha <- 1 # 1
  beta <- 0.68 # 0.68
  tau <- 0.75 # 0.75

  # Classic
  like <- likelihood.Gomez2013(trees, alpha = alpha, beta = beta, tau = tau)
  cat('\n alpha: ', alpha)
  cat('\n beta: ', beta)
  cat('\n tau:', tau)
  cat('\n Total likelihood: ', like)

  # Using preprocessed dataframes
  df.trees_ <- filter(df.trees, t>1)
  like <- likelihood.Gomez2013.df(df.trees_, alpha = alpha, beta = beta, tau = tau)
  cat('\n alpha: ', alpha)
  cat('\n beta: ', beta)
  cat('\n tau:', tau)
  cat('\n Total likelihood: ', like)

  # Using preprocessed dataframes + cluster by cluster
  alphas <- c(1,2)
  betas <- c(0.68,0.75)
  taus <- c(0.75, 0.75)
  users <- unique(df.trees$user)
  z <- c(1,1)

  # this is parallelizable
  like <- 0
  z.nonempty <- unique(z)
  for (i in 1:length(z.nonempty)){
    like <- like + likelihood.Lumbreras2016.users(df.trees_,
                                                  which(z==z.nonempty[i]),
                                                  alphas[z.nonempty[i]],
                                                  betas[z.nonempty[i]],
                                                  taus[z.nonempty[i]])
  }
  cat('\n Total likelihood: ', like)

  library(rbenchmark)
  benchmark(likelihood.Gomez2013(trees, alpha = alpha, beta = beta, tau = tau),
            likelihood.Gomez2013.df(df.trees_, alpha = alpha, beta = beta, tau = tau),
            likelihood.Lumbreras2016.users(df.trees_,
                                           which(z==z.nonempty[1]),
                                           alphas[z.nonempty[1]],
                                           betas[z.nonempty[1]],
                                           taus[z.nonempty[1]]))

}


# ************************************************
### simon munzert
### R exercises
# ************************************************

source("packages.r")
source("functions.r")

### practice at home using Swirl -----------------

# check out the Swirl project - it's fantastic!
browseURL("http://swirlstats.com/")

# install Swirl
install.packages("swirl")
library(swirl)

# launch Swirl
swirl()

simpleCondition()# install a course, for instance
install_course("R Programming")
#install_course("Regression Models")
install_course("Getting and Cleaning Data")

# check out which courses are available
browseURL("https://github.com/swirldev/swirl_courses")

# | When you are at the R prompt (>):
# | -- Typing skip() allows you to skip the current question.
# | -- Typing play() lets you experiment with R on your own; swirl will ignore what you do
# | -- ... UNTIL you type nxt() which will regain swirl's attention.
# | -- Typing bye() causes swirl to exit. Your progress will be saved.
# | -- Typing main() returns you to swirl's main menu.
# | -- Typing info() displays these options again.

### some R exercises --------------------------

## Exercise 1

# a) Consider the following vector. What's the mean of all values?
# b) And what's the median? What about the variance and the standard deviation?
# c) Compute the sum of all values.

x <- c(34, 56, 55, 87, NA, 4, 77, NA, 21, NA, 39)
x[!is.na(x)]
mean(x, na.rm = TRUE)
median(x, na.rm = TRUE)
var(x, na.rm = TRUE)
sd(x, na.rm = TRUE)
sum(x, na.rm = TRUE)

## Exercise 2

# a) Create a vector with 5 of your friends' names.
# b) Get the length of the vector.
# c) Extract the first two friends of the vector.
# d) Extract the second and the last observation from the vector.
# e) Sort your friends by their names.
# f) Reverse the direction of the above sort.

friends <- c("Homer", "Marge", "Bart", "Lisa", "Maggie")
length(friends)
friends[1:2]
friends[c(1, 5)]
friends[c(1, length(friends))]
sort(friends)
rev(sort(friends))
sort(friends, decreasing = TRUE)

## Exercise 3

# a) Here are some variables in vector format. Combine these by creating a data frame!
# b) Add a new variable, height, with the following values: 182, 170, 163, 175, 165, 150
# c) Visualize the relationship between age and height!

age <- c(22, 25, 18, 20, 32, 15)
name <- c("James", "Matthew", "Bill", "Lucie", "Olivia", "Stella")
gender <- c("M", "M", "M", "F", "F", "F")

## Exercise 4

# a) Calculate the root of 729.
# b) Draw a random sample of n = 50 of the sample 1:100 with replacement.
# c) Draw 20 values from the Uniform distribution on the interval from 0 to 10.

## Exercise 5

# a) Import the dataset "btw17_kerg.csv", which contains district-level results for the 2017 German federal election!
# b) Generate a set of new variables, cdsu1, cdsu1_last, cdsu2, cdsu2_last, which combines the votes for CDU and CSU!
# b) Generate the shares of the second vote for all major parties and compare them with the published results!
# c) Identify the district(s) in which the SPD improved its share of the vote!
# d) Generate a new variable that indicates the district winning party (i.e. the party with the most first votes!)
# e) Build a bar chart that visualizes the vote shares for all parties! The following link might help: http://www.statmethods.net/graphs/bar.html

dat <- read_tsv("../data/btw17_kerg.csv")
dat[is.na(dat)] <- 0
dat <- mutate(dat, cdsu1 = cdu1 + csu1,
                   cdsu1_last = cdu1_last + csu1_last,
              )

## Exercise 6

# a) Load the following dataset into R, which contains data on immigration to Ellis Island (1892-1924) by trip.
# b) What is the total number of immigration cases in the dataset?
# c) From where did the ship with the most immigrants arrive?
# d) How many unique ships (according to the name) are in the dataset?
# e) Which ship carried the most immigrants in total?
# f) Create a date variable using the lubridate package.
# g) Aggregate the count variable by date (daily level) and generate a time series plot using these data.

url <- "https://raw.githubusercontent.com/hopperrr/ellis-immigration-by-ship/gh-pages/data/trips.tsv"


rotate <- function(x,xAxisTo=0,Center=c(0,0),Angle=xAxisTo-90,nms=c("x","y")){
	ang <- -Angle/180
	ctr <- Center
	UseMethod("rotate",x)
}
rotate.default <- function(x,xAxisTo=0,Center=c(0,0),Angle=xAxisTo-90,nms=c("x","y")){
	if(!is.numeric(nms)){
		nms <- match(nms,names(x),nomatch=0)
		nms[!nms] <- (c(1,2) %w/o% nms)[seq_len(sum(nms==0))]
	}
	x[[nms[1]]] <- x[[nms[1]]] - ctr[1]
	x[[nms[2]]] <- x[[nms[2]]] - ctr[2]
	out <- x
	out[[nms[1]]] <- x[[nms[1]]] * cospi(ang) - x[[nms[2]]] * sinpi(ang)  + ctr[1]
	out[[nms[2]]] <- x[[nms[1]]] * sinpi(ang) + x[[nms[2]]] * cospi(ang)  + ctr[2]
	return(out)
}
rotate.matrix <- function(x,xAxisTo=0,Center=c(0,0),Angle=xAxisTo-90,nms=c("x","y")){
	if(!is.numeric(nms)){
		nms <- match(nms,colnames(x),nomatch=0)
		nms[!nms] <- (c(1,2) %w/o% nms)[seq_len(sum(nms==0))]
	}
	x[,nms[1]] <- x[,nms[1]] - ctr[1]
	x[,nms[2]] <- x[,nms[2]] - ctr[2]
	out <- x
	out[,nms[1]] <- x[,nms[1]] * cospi(ang) - x[,nms[2]] * sinpi(ang)  + ctr[1]
	out[,nms[2]] <- x[,nms[1]] * sinpi(ang) + x[,nms[2]] * cospi(ang)  + ctr[2]
	return(out)
}
rotate.data.table <- function(x,xAxisTo=0,Center=c(0,0),Angle=xAxisTo-90,nms=c("x","y")){
	if(is.numeric(nms)){
		nms <- names(x)[nms]
	}
	xnms <- x[,.(
		nms1 = get(nms[1]) - ctr[1]
		,nms2 = get(nms[2]) - ctr[2]
		)]
	x[,nms[1] := xnms[,nms1] * cospi(ang) - xnms[,nms2] * sinpi(ang)  + ctr[1],with=FALSE]
	x[,nms[2] := xnms[,nms1] * sinpi(ang) + xnms[,nms2] * cospi(ang)  + ctr[2],with=FALSE]
	invisible(x)
}


library(readxl)

setwd ("c://R")
EmployeesSalary <- read_excel("employees.xlsx")

summary(EmployeesSalary)

EmployeesSalary$LevelOfEmployee <- as.factor(EmployeesSalary$LevelOfEmployee)

summary(EmployeesSalary)

pch.list <- as.numeric(EmployeesSalary$LevelOfEmployee)
plot(EmployeesSalary$YearsExperience, EmployeesSalary$Salary, pch=c(pch.list))

LMcat <- lm('Salary~YearsExperience*LevelOfEmployee',data=EmployeesSalary)
LMcat

LMcat.coef <- coef(LMcat)
LMcat.coef
LMcat.GeneralStaff <- c(LMcat.coef[1],LMcat.coef[2])
LMcat.GeneralStaff
LMcat.TechnicalStaff <- c(LMcat.coef[1]+LMcat.coef[4],LMcat.coef[2]+LMcat.coef[6])
LMcat.TechnicalStaff
LMcat.Management <- c(LMcat.coef[1]+LMcat.coef[3],LMcat.coef[2]+LMcat.coef[5])
LMcat.Management

pch.list <- as.numeric(EmployeesSalary$LevelOfEmployee)
plot(EmployeesSalary$YearsExperience, EmployeesSalary$Salary, pch=c(pch.list),cex.axis=0.6,cex.lab=0.6)
abline(coef=LMcat.GeneralStaff,lwd=2)
abline(coef=LMcat.TechnicalStaff,lwd=2)
abline(coef=LMcat.Management,lwd=2)

summary(LMcat)


##
## social relations model using amen package
## - https://cran.r-project.org/web/packages/amen/vignettes/amen.pdf
##
source("init if necessary.r")

library(amen)

flog.info("Fitting social relations models")

#################################################################
## fit Saami SRM
##

##
## create adjacency matrices
##
# get adjacency matrices for gifts, cooperation, kinship and herding group co-membership
adj.gifts = get.adjacency(g.gifts, sparse = F)
adj.kin   = get.adjacency(g.kin,   sparse = F, attr="r")
adj.siida = get.adjacency(g.siida, sparse = F)
adj.coop  = get.adjacency(g.netmap.o, sparse = F)

# (self-loops must be set to NA)
diag(adj.gifts) = NA
diag(adj.kin)   = NA
diag(adj.siida) = NA
diag(adj.coop)  = NA

# dyadic covariates: relatedness, named in cooperative network, herding group co-membership
X_dyad = array(dim=c(nrow(adj.kin), ncol(adj.kin), 3))
X_dyad[,,1] = adj.kin
X_dyad[,,2] = adj.siida
X_dyad[,,3] = adj.gifts
dimnames(X_dyad)[[3]] = c("kin", "siida", "gifts")

# dyadic covariates, including siida x relatedness interaction
X_dyad_int = array(dim=c(nrow(adj.kin), ncol(adj.kin), 4))
X_dyad_int[,,1] = adj.kin
X_dyad_int[,,2] = adj.siida
X_dyad_int[,,3] = adj.gifts
X_dyad_int[,,4] = adj.kin * adj.siida
dimnames(X_dyad_int)[[3]] = c("kin", "siida", "gifts", "kin x siida")

# dyadic covariates, including siida x relatedness x gift interaction
X_dyad_all = array(dim=c(nrow(adj.kin), ncol(adj.kin), 7))
X_dyad_all[,,1] = adj.kin
X_dyad_all[,,2] = adj.siida
X_dyad_all[,,3] = adj.gifts
X_dyad_all[,,4] = adj.kin * adj.siida
X_dyad_all[,,5] = adj.kin * adj.gifts
X_dyad_all[,,6] = adj.siida * adj.gifts
X_dyad_all[,,7] = adj.kin * adj.siida * adj.gifts
dimnames(X_dyad_all)[[3]] = c("kin", "siida", "gifts", "kin x siida", "kin x gifts", "siida x gifts", "kin x siida x gifts")

# individual covariates: interviewed/not?
X_ind = as.matrix(subset(herders, select=c(Interviewed.)))
dimnames(X_ind)[[2]] = c("interviewed")

##
## fit models
##
flog.info("... fitting intercept-only models")

# fit intercept-only models
fit_null      = ame(adj.coop, model="bin", plot=F, print=F)
fit_null_ind  = ame(adj.coop, Xr=X_ind, model="bin", plot=F, print=F)                    # intercept-only, but controlling for whether/not ego was interviewed

flog.info("... fitting model: r + siida + gifts")

# fit with dyadic and individual covariates
fit_srrm2 = ame(adj.coop,       # response adjacency matrix
                Xd=X_dyad,      # array of dyadic covariates
                Xr=X_ind,       # node row covariates (missing values are replaced with zeros)
                model="bin",
                plot=F, print=F)

flog.info("... fitting model: r x siida + gifts")

# fit with r x siida interaction
fit_srrm3 = ame(adj.coop,       # response adjacency matrix
                Xd=X_dyad_int,  # array of dyadic covariates, including r x siida interaction
                Xr=X_ind,       # node row covariates (missing values are replaced with zeros)
                model="bin",
                plot=F, print=F)

flog.info("... fitting model: r x siida x gifts")

# fit with all interactions
fit_srrm4 = ame(adj.coop,       # response adjacency matrix
                Xd=X_dyad_all,  # array of dyadic covariates, including r x siida interaction
                Xr=X_ind,       # node row covariates (missing values are replaced with zeros)
                model="bin",
                plot=F, print=F)

####################################################################
## Link functions for each model
## - they'll be used in model comparison and analysis
##
# inverse probit link function
## found out how to calculate this by fitting a nonsense probit model:
##   myprobit <- glm(Interviewed. ~ 1, family=binomial(link="probit"), data=herders)
## then looking at the code in `family(myprobit)$linkinv`
probit = function(eta)
{
  thresh <- -qnorm(.Machine$double.eps)  # `.Machine$double.eps` == the smallest positive floating-point number x such that 1 + x != 1
  eta <- pmin(pmax(eta, -thresh), thresh)
  pnorm(eta)
}

# functions for posterior predictions
# - m is the SRM
# - r is relatedness (0-0.5)
# - siida is group co-membership (0, 1)
# - coop is whether/not alter named ego in their cooperative network
# - re is the random effects

p.link_null = function(m, r=0, siida=0, gift=0, re=0) {
  post = m$BETA

  eta = post[,1] +         # intercept
    post[,2] +             # people we interviewed
    re                     # random effects

  return( probit(eta) )
}

p.link_srrm2 = function(m, r, siida, gift, re=0) {
  post = m$BETA

  eta = post[,1] +         # intercept
    post[,2] +             # people we interviewed
    post[,3]*r +           # relatedness
    post[,4]*siida +       # members of same siida?
    post[,5]*gift +        # ego gave alter a gift?
    re                     # random effects

  return( probit(eta) )
}

p.link_srrm3 = function(m, r, siida, gift, re=0) {
  post = m$BETA

  eta = post[,1] +          # intercept
    post[,2] +              # people we interviewed
    post[,3]*r +            # relatedness
    post[,4]*siida +        # members of same siida?
    post[,5]*gift +         # ego gave alter a gift?
    post[,6] * r * siida +  # r x siida interaction
    re                      # random effects

  return( probit(eta) )
}

p.link_srrm4 = function(m, r, siida, gift, re=0) {
  post = m$BETA

  eta = post[,1] +                 # intercept
    post[,2] +                     # people we interviewed
    post[,3]*r +                   # relatedness
    post[,4]*siida +               # members of same siida?
    post[,5]*gift +                # ego gave alter a gift?
    post[,6] * r * siida +         # r x siida interaction
    post[,7] * r * gift +          # r x gift interaction
    post[,8] * siida * gift +      # siida x gift interaction
    post[,9] * r * siida * gift +  # r x siida x gift interaction
    re                             # random effects

  return( probit(eta) )
}

#######################################################################
## Save models etc.
##
save(X_dyad, X_dyad_int, X_dyad_all, adj.coop, adj.kin, adj.siida, adj.gifts,
     fit_null, fit_null_ind, fit_srrm2, fit_srrm3, fit_srrm4,
     p.link_null, p.link_srrm2, p.link_srrm3, p.link_srrm4, probit,
     file=file.path(models.dir, "social relations models.rdata"))

flog.info("Finished fitting social relations models")


#' @title
#' Select ranks with information criterion
#'
#' @description
#' This function selects the optimal ranks \code{(r, rx, ry)} using a user-specified
#' information criterion. The degrees of freedom is estimated by the number of
#' free parameters in the model. The blockwise coordinate descent algorithm is used to fit
#' the model with any combinations of \code{(r, rx, ry)}.
#'
#' @usage
#' NRRR.ic(Y, X, Ag0 = NULL, Bg0 = NULL,
#'         jx, jy, p, d, n, maxiter = 300, conv = 1e-4,
#'         method = c('RRR','RRS')[1],
#'         lambda = 0, ic = c("BIC","BICP","AIC","GCV")[1],
#'         dimred = c(TRUE,TRUE,TRUE), rankfix = NULL,
#'         xrankfix = NULL, yrankfix = NULL,
#'         lang = c('R', 'Rcpp')[1])
#'
#' @param Y response matrix of dimension n-by-jy*d.
#' @param X design matrix of dimension n-by-jx*p.
#' @param Ag0 an initial estimator of matrix U. If \code{Ag0 = NULL} then generate it
#'            by \code{\link{NRRR.ini}}. Default is NULL. If \code{lang = 'Rcpp'},
#'            then \code{Ag0} is automatically generated by \code{\link{NRRR.ini}}.
#' @param Bg0 an initial estimator of matrix V, if \code{Bg0 = NULL} then generate it
#'            by \code{\link{NRRR.ini}}. Default is NULL. If \code{lang = 'Rcpp'},
#'            then \code{Bg0} is automatically generated by \code{\link{NRRR.ini}}.
#' @param jx number of basis functions to expand the functional predictor.
#' @param jy number of basis functions to expand the functional response.
#' @param p number of predictors.
#' @param d number of responses.
#' @param n sample size.
#' @param maxiter the maximum iteration number of the
#'                blockwise coordinate descent algorithm. Default is 300.
#' @param conv the tolerance level used to control the convergence of the
#'             blockwise coordinate descent algorithm. Default is 1e-4.
# @param quietly a logical value with two options. FALSE (default): show the
#                rank selection process; TRUE: do not show the process. If
#                \code{lang = 'Rcpp'}, then \code{quietly} is automatically
#                set to TRUE.
#' @param method 'RRR' (default): no additional ridge penalty; 'RRS': add an
#'               additional ridge penalty.
#' @param lambda the tuning parameter to control the amount of ridge
#'               penalization. It is only used when \code{method = 'RRS'}.
#'               Default is 0.
#' @param ic the user-specified information criterion. Four options are available,
#'           i.e., BIC, BICP, AIC, GCV.
#' @param dimred a vector of logical values to decide whether to use the selected information criterion
#'               do rank selection on certain dimensions. TRUE means the rank is selected
#'               by the selected information criterion. If \code{dimred[1] = FALSE}, r is
#'               provided by \code{rankfix} or \eqn{min(jy*d, rank(X))};
#'               If \code{dimred[2] = FALSE}, rx equals to \code{xrankfix} or p; If \code{dimred[3] = FALSE},
#'               ry equals to \code{yrankfix} or d. Default is \code{c(TRUE, TRUE, TRUE)}.
#' @param rankfix a user-provided value of r when \code{dimred[1] = FALSE}. Default is NULL
#'                which leads to \eqn{r = min(jy*d, rank(X))}.
#' @param xrankfix a user-provided value of rx when \code{dimred[2] = FALSE}. Default is NULL
#'                 which leads to \code{rx = p}.
#' @param yrankfix a user-provided value of ry when \code{dimred[3] = FALSE}. Default is NULL
#'                 which leads to \code{ry = d}.
#' @param lang 'R' (default): the R version function is used; 'Rcpp': the Rcpp
#'             version function is used.
#' @return The function returns a list:
#'   \item{Ag}{the estimated U.}
#'   \item{Bg}{the estimated V.}
#'   \item{Al}{the estimated A.}
#'   \item{Bl}{the estimated B.}
#'   \item{C}{the estimated coefficient matrix C.}
#'   \item{df}{the estimated degrees of freedom of the NRRR model.}
#'   \item{sse}{the sum of squared errors of the selected model.}
#'   \item{ic}{a vector containing values of BIC, BICP, AIC, GCV of the selected model.}
#'   \item{rank}{the estimated r.}
#'   \item{rx}{the estimated rx.}
#'   \item{ry}{the estimated ry.}
#'
#'
#' @details
#' Denote \eqn{\hat C(r, rx, ry)} as the estimator of the coefficient matrix
#' with the rank values fixed at some \eqn{(r, rx, ry)} and write the sum of
#' squared errors as \eqn{SSE(r, rx, ry)=||Y - X\hat C(r, rx, ry)||_F^2}. We
#' define
#' \deqn{BIC(r, rx, ry) = n*d*jy*log(SSE(r, rx, ry)/(n*d*jy)) + log(n*d*jy)*df(r, rx, ry),}
#' where \eqn{df(r, rx, ry)} is the effective degrees of freedom and is estimated
#' by the number of free parameters
#' \deqn{\hat df(r, rx, ry) = rx*(rank(X)/jx - rx) + ry*(d - ry) + (jy*ry + jx*rx - r)*r.}
#' We can define other information criteria in a similar way. With the defined BIC,
#' a three-dimensional grid search procedure of the rank
#' values is performed, and the best model is chosen as the one with the
#' smallest BIC value. Instead of a nested rank selection method, we apply a
#' one-at-a-time selection approach. We first set \eqn{rx = p, ry = d}, and
#' select the best local rank \eqn{\hat r} among the models with
#' \eqn{1 \le r \le min(rank(X), jy*d)}. We then fix the local rank at
#' \eqn{\hat r} and repeat a similar procedure to determine \eqn{\hat rx}
#' and \eqn{\hat ry}, one at a time. Finally, with fixed \eqn{\hat rx} and \eqn{\hat ry},
#' we refine the estimation of r.
#'
#'
#' @references Liu, X., Ma, S., & Chen, K. (2020).
#' Multivariate Functional Regression via Nested Reduced-Rank Regularization.
#' arXiv: Methodology.
# @importFrom rrpack cv.rrr
#' @export
#' @examples
#' library(NRRR)
#' set.seed(3)
#' # Simulation setting 2 in NRRR paper
#' simDat <- NRRR.sim(n = 100, ns = 100, nt = 100, r = 3, rx = 3, ry = 3,
#'                    jx = 8, jy = 8, p = 20, d = 20, s2n = 1, rho_X = 0.5,
#'                    rho_E = 0, Sigma = "CorrAR")
#' # using R function
#' fit_R <- with(simDat, NRRR.ic(Yest, Xest, Ag0 = NULL, Bg0 = NULL,
#'               jx = 8, jy = 8, p = 20, d = 20, n = 100,
#'               maxiter = 300, conv = 1e-4, method = c("RRR", "RRS")[1],
#'               lambda = 0, ic = c("BIC", "BICP", "AIC", "GCV")[1],
#'               dimred = c(TRUE, TRUE, TRUE), rankfix = NULL,
#'               xrankfix = NULL, yrankfix = NULL,
#'               lang=c('R','Rcpp')[1]))
#' # using Rcpp function
#' fit_Rcpp <- with(simDat, NRRR.ic(Yest, Xest, Ag0 = NULL, Bg0 = NULL,
#'                  jx = 8, jy = 8, p = 20, d = 20, n = 100,
#'                  maxiter = 300, conv = 1e-4, method = c("RRR", "RRS")[1],
#'                  lambda = 0, ic = c("BIC", "BICP", "AIC", "GCV")[1],
#'                  dimred = c(TRUE, TRUE, TRUE), rankfix = NULL,
#'                  xrankfix = NULL, yrankfix = NULL,
#'                  lang=c('R','Rcpp')[2]))
NRRR.ic <- function(Y,X,Ag0=NULL,Bg0=NULL,
                    jx,jy,p,d,n,maxiter=300,conv=1e-4,
                    method=c('RRR','RRS')[1],
                    lambda=0,ic=c("BIC","BICP","AIC","GCV")[1],
                    dimred = c(TRUE,TRUE,TRUE),rankfix=NULL,
                    xrankfix=NULL, yrankfix=NULL,
                    lang=c('R','Rcpp')[1]
){
  #require(rrpack)
  if (method == "RRS" & lambda == 0) stop("A positive tuning parameter should be provided when 'RRS' is used.")
  if (!(ic %in% c("BIC","BICP","AIC","GCV"))) stop("A valid information criterion name should be provided.")
  if (!(lang %in% c('R','Rcpp'))) stop("Please choose from 'R' and 'Rcpp'")

  # compute rank(X)
  xr <- sum(svd(X)$d>1e-2)

  # initialize r
  if(dimred[1]){
    fitRRR <- cv.rrr(Y,X,nfold=10)
    rest <- fitRRR$rank
    # If zero fit
    if(rest==0){
      fitRRR <- RRR(Y,X,nrank=1)
      rest <- fitRRR$rank
    }
    # if(!quietly) {
    #   cat("Initial r   = ",rest, "\n",sep="")
    # }
  }else{
    rest <- ifelse(is.null(rankfix),min(ncol(Y),ncol(X),xr),rankfix)
  }
  rfit <- rest

  if (lang == "R"){
    # Select rx
    if(dimred[2]){
      rxfitseq <- 1:p
      ryfitseq <- rep(d,length(rxfitseq))

      icseq <- vector()
      for(i in 1:length(rxfitseq)){
        rxfit <- rxfitseq[i]
        ryfit <- ryfitseq[i]
        fit1 <- NRRR.est(Y,X,NULL,NULL,rini=rfit,rfit,rxfit,ryfit,jx,jy,p,
                         d,n,maxiter=maxiter,conv=conv,#quietly=TRUE,
                         method=method,lambda=lambda)
        icseq[i] <- switch(ic,'BIC'=fit1$ic[1],'BICP'=fit1$ic[2],
                           'AIC'=fit1$ic[3],'GCV'=fit1$ic[4])
      }
      rxest <- rxfitseq[which.min(icseq)]
    }else{
      #rxest <- p
      rxest <- ifelse(is.null(xrankfix),p,xrankfix)
    }
    rxfit <- rxest
    # if(!quietly) {
    #   cat("Selected rx = ",rxest, "\n",sep="")
    # }

    # Select ry
    if(dimred[3]){
      ryfitseq <- 1:d
      rxfitseq <- rep(rxest,length(ryfitseq))

      icseq <- vector()
      for(i in 1:length(rxfitseq)){
        rxfit <- rxfitseq[i]
        ryfit <- ryfitseq[i]
        fit1 <- NRRR.est(Y,X,NULL,NULL,rini=rfit,rfit,rxfit,ryfit,jx,jy,
                         p,d,n,maxiter=maxiter,conv=conv,#quietly=TRUE,
                         method=method,lambda=lambda)
        icseq[i] <- switch(ic,'BIC'=fit1$ic[1],'BICP'=fit1$ic[2],
                           'AIC'=fit1$ic[3],'GCV'=fit1$ic[4])
      }
      ryest <- ryfitseq[which.min(icseq)]
    }else{
      #ryest <- d
      ryest <- ifelse(is.null(yrankfix),d,yrankfix)
    }
    ryfit <- ryest
    # if(!quietly) {
    #   cat("Selected ry = ",ryest, "\n",sep="")
    # }

    # refine rank selection
    if(dimred[1]){
      rxfit <- rxest
      ryfit <- ryest
      icseq <- vector()
      # range of the possible rank
      rfitseq <- max(1,rest-5):min(rest+5,min(n,p*jx,d*jy))

      rfit <- rfitseq[1]
      fit <- NRRR.est(Y,X,NULL,NULL,rini=rfit,rfit,rxfit,ryfit,jx,jy,
                      p,d,n,maxiter=maxiter,conv=conv,#quietly=TRUE,
                      method=method,lambda=lambda)
      icseq[1] <- switch(ic,'BIC'=fit$ic[1],'BICP'=fit$ic[2],
                         'AIC'=fit$ic[3],'GCV'=fit$ic[4])
      icmin <- icseq[1]
      for(i in 2:length(rfitseq)){
        rfit <- rfitseq[i]
        fit1 <- NRRR.est(Y,X,NULL,NULL,rini=rfit,rfit,rxfit,ryfit,jx,jy,
                         p,d,n,maxiter=maxiter,conv=conv,#quietly=TRUE,
                         method=method,lambda=lambda)
        icseq[i] <- switch(ic,'BIC'=fit1$ic[1],'BICP'=fit1$ic[2],
                           'AIC'=fit1$ic[3],'GCV'=fit1$ic[4])
        if(icseq[i]<icmin){
          fit <- fit1
          icmin <- icseq[i]
        }
      }
      rest <- rfitseq[which.min(icseq)]
    }else{
      fit <- NRRR.est(Y,X,NULL,NULL,rini=rest,rest,rxfit,ryfit,jx,jy,
                      p,d,n,maxiter=maxiter,conv=conv,#quietly=TRUE,
                      method=method,lambda=lambda)
    }
    if (fit$iter == maxiter) stop("The algorithm reaches the maximum iteration.")

    return(list(Ag=fit$Ag,Bg=fit$Bg,Al=fit$Al,Bl=fit$Bl,C=fit$C,df=fit$df,
                sse=fit$sse,ic=fit$ic,#obj=fit$obj,
                rank=rest,rx=rxest,ry=ryest))
  } else {
    method <- ifelse(method == 'RRR', 1, 2)

    dimred1 <- ifelse(dimred[1],1,0)
    dimred2 <- ifelse(dimred[2],1,0)
    dimred3 <- ifelse(dimred[3],1,0)

    xrankfix <- ifelse(is.null(xrankfix),0,xrankfix)
    yrankfix <- ifelse(is.null(yrankfix),0,yrankfix)

    if (ic == 'BIC'){
      ic_num <- 0
    } else if (ic == 'BICP'){
      ic_num <- 1
    } else if (ic == 'AIC'){
      ic_num <- 2
    } else {
      ic_num <- 3
    }

    fit <- nrrr_select_my(Y, X, xr, rfit, xrankfix, yrankfix, jx, jy, p, d, n, ic_num, maxiter, conv,
                          method, lambda, dimred1, dimred2, dimred3)
    if( sum(fit$rxErrseq)>0 | sum(fit$ryErrseq)>0 | sum(fit$rErrseq)>0 ) stop('Error occurs or the algorithm reaches the maximum iteration')

    return(list(Ag=fit$Ag,Bg=fit$Bg,Al=fit$Al,Bl=fit$Bl,C=fit$C,df=fit$df,
                sse=fit$sse,ic=fit$ic,#obj=fit$obj,
                rank=fit$rank,rx=fit$rx,ry=fit$ry
                #,rxErrseq=fit$rxErrseq,ryErrseq=fit$ryErrseq,rErrseq=fit$rErrseq
                ))
  }
}


rm(list=ls())

file.maf = commandArgs()[4]
fraction_maf.thresh = as.numeric(commandArgs()[5])

maf = read.table(file.maf, as.is=T, header=T)
maf.log10_MAF = log10(maf$MAF)

png(file=paste(file.maf, ".logscale.2.png", sep=""), width=960, height=960)

hist(maf.log10_MAF, xlim=c(-4,0), main="QCed SNPs", xlab="MAF", ylab="Number of SNPs", col="grey", border="black", axes=F)
axis(1, at=c(-4,-3,-2,log10(fraction_maf.thresh),-1,0), labels=c(0.0001,0.001,0.01,fraction_maf.thresh,0.1,1))
axis(2, at=seq(0,2000000,20000), tick=T)
abline(v=log10(fraction_maf.thresh), col="red", lty=2)

dev.off()


#' Compute principal components of a methylation matrix.
#'
#' @param  normalized.beta Output from \code{\link{meffil.normalize.samples}()},
#' either a matrix or a GDS filename.
#' @param  probe.range Default = 5000. How many probes to be used in calculating PCs
#' @param  autosomal Default = TRUE. If true, remove probes on sex chromosomes.
#' @param  verbose=T Print progress messages?
#' @return the principal components of \code{normalized.beta}.
#'
#' @export
meffil.methylation.pcs <- function (normalized.beta, probe.range = 5000, autosomal = T, verbose = F) {
    if (is.matrix(normalized.beta))
        sites <- rownames(normalized.beta)
    else {
        gds.filename <- normalized.beta
        stopifnot(file.exists(gds.filename))
        gds.file <- openfn.gds(gds.filename)
        on.exit(closefn.gds(gds.file))

        sites <- read.gdsn(index.gdsn(gds.file, "row.names"))
    }

    subset <- sites

    if (autosomal) {
        featureset <- meffil:::guess.featureset(sites)
        autosomal.sites <- meffil.get.autosomal.sites(featureset)
        subset <- intersect(autosomal.sites, subset)
    }

    meffil:::msg("Calculating variances", verbose = verbose)
    if (is.matrix(normalized.beta)) {
        var.sites <- meffil.most.variable.cpgs(normalized.beta[subset,], n = probe.range)

    } else {
        cores <- getOption("mc.cores", 1)
        cl <- parallel::makeCluster(cores)
        vars <- clusterApply.gdsn(cl=cl,
                                  gds.fn=gds.filename,
                                  node.name="matrix",
                                  margin=1,
                                  as.is="double",
                                  FUN=function(x) var(x, na.rm=T))
        vars <- vars[match(subset, sites)]
        var.sites <- subset[order(vars, decreasing=T)[1:probe.range]]
    }
    var.idx <- match(var.sites, sites)

    meffil:::msg("Calculating beta PCs", verbose = verbose)
    if (is.matrix(normalized.beta))
        mat <- normalized.beta[var.idx,]
    else {
        matrix.node <- index.gdsn(gds.file, "matrix")
        mat <- t(sapply(var.idx, function(idx)
                        read.gdsn(matrix.node, start=c(idx,1), count=c(1,-1))))
    }

    prcomp(t(meffil:::impute.matrix(mat, margin = 1)))$x
}