#### 일원 분산분석(One-way ANOVA) #####

# 01.데이터 불러오기
owa.df <- read.csv("Ch0903.교육역량분석.csv",
                   header=TRUE,
                   na.strings = ".")

owa.df$학년 <- factor(owa.df$학년,
                       levels = c(1:4),
                       labels = c("1학년","2학년","3학년","4학년"))

str(owa.df)
head(owa.df)

# 02.기본통계치 확인
library(psych)
describeBy(owa.df$비교과운영,
           owa.df$학년,
           mat=T) # 합쳐서 하나의 표로 보여줄지, 따로 그룹별로 보여줄지 나타내는 옵션

# 03.그래프 그리기(박스그래프,히스토그램)
# install.packages("ggplot2")

library(ggplot2)

ggplot(owa.df, aes(x = 학년, y = 비교과운영)) + #aes 축
  geom_boxplot(outlier.colour="red") + #이상치를 레드로 하라
  ggtitle("학년별 점수 차이") +
  theme_classic() + # ggplot2 테마
  theme(title = element_text(color="darkblue", size=20))

# facet_grid(); 그룹으로 구분- 범주형 변수
# facet_grid(.~); 수직
# facet_grid(~.); 가로

ggplot(owa.df, aes(x=비교과운영)) +
  geom_histogram(binwidth=10) +
  facet_grid(.~ 학년) +
  ggtitle("매장별 만족도") +
  theme_classic()

# 04.통계분석
# 등분산 검증
# 이분산일때는 하단의 부록(Welch's ANOVA test) 참조
bartlett.test(비교과운영 ~ 학년, data=owa.df)

# barlett test는 정규분포에 민감하기 때문에 leveneTest 많이 사용
# install.packages("car")
library(car)
car::leveneTest(비교과운영 ~ 학년, data=owa.df) # 레벤의 검증은 library(car)에 있다.

# 등분산일때 ANOVA분석
owa.result <- aov(비교과운영 ~ 학년, data=owa.df)

owa.result

summary(owa.result)

# 부록: 이분산일때 Welch's ANOVA test
oneway.test(owa.df$비교과운영 ~ owa.df$학년, data=owa.df,
            var.equal = FALSE)

# 사후검정(Multicamparison test )
# Fisher LSD
pairwise.t.test(owa.df$비교과운영,
                owa.df$학년,
                data=owa.df,
                p.adj="non") # 많이 않쓰임. 오차가 크기 때문에

# Bonferroni, Tukey HSD, Duncan LSR
pairwise.t.test(owa.df$비교과운영,
                owa.df$학년,
                data=owa.df,
                p.adj="bonf") # 여기서비교하는 방법을 알려줌. 이것은 유의확률을 보여줌. 강남-강동 차이 있음

# Tukey HSD, Duncan LSR
TukeyHSD(owa.result) # 결과값으로 바로 보여줌 (분산분석 결과치를 데이타프레임으로 저장하고 입력)

# 학년으로 표현
# install.packages("agricolae")
library(agricolae)

# console=TRUE: 결과를 화면에 표시
# 학년=TRUE: 그룹으로 묶어서 표시, FALSE: 1:1로 비교하여 다 보여줌, 다른 것끼리 구분되는 것
LSD.test(owa.result,
         "학년",
         console = T,
         p.adj="bonf")
duncan.test(owa.result,
            "학년",
            group=T,
            console = T)
scheffe.test(owa.result,
             "학년",
             group=T,
             console = T)

# 05.통계결과 그래프
tukeyPlot <- TukeyHSD(owa.result) # 그룹간 차이 비교
plot(tukeyPlot) # 0을 거치고 있다는 것은 차이가 없다는 뜻임

# 부록: 비모수통계분석 Kruskal Wallis H test
kruskal.test(owa.df$비교과운영 ~ owa.df$학년,
             data=owa.df)
# install.packages("userfriendlyscience")
library(userfriendlyscience)
posthocTGH(owa.df$비교과운영,
           owa.df$학년)

# install.packages("nparcomp")  # 비모수 검정에서 다중 비교 방식
library(nparcomp)
result = mctp(owa.df$비교과운영 ~ owa.df$학년,
              data=owa.df)
summary(result)


 DGEBRD Example Program Results

 Diagonal
    3.6177   2.4161  -1.9213  -1.4265
 Superdiagonal
    1.2587   1.5262  -1.1895


#' Function for generated heatmap of the covariance matrix of the Amen data
#'
#' This function generates a heatmap of the covariance matrix of the Amen data
#' @param data Accepts a list with first row containing adult data and second row containing child data.
#' @export
#' @examples
#' Variance-Heatmaps()

Variance_Heatmaps <- function(data){
	require(graphics)
	require(ggplot2)
	require(reshape)

	#Split data
	data_adults <- data[[1]]
	data_children <-data[[2]]

	#Find columns of interest
	data_adults <- data_adults[,c(8,381:636)]
	data_children <- data_children[,c(8,381:636)]

	data_adults_baseline <- data_adults[,c(1,2:129)];
	data_adults_concentration <- data_adults[,c(1,130:257)];
	data_children_baseline <- data_children[,c(1,2:129)];
	data_children_concentration <- data_children[,c(1,130:257)];

	#Separate into male and female
	data_adults_baseline_m <- data_adults_baseline[grep('Male', data_adults_baseline$Gendername),]
	data_adults_baseline_f <- data_adults_baseline[grep('Female', data_adults_baseline$Gendername),]
	data_adults_concentration_m <- data_adults_baseline[grep('Male', data_adults_concentration$Gendername),]
	data_adults_concentration_f <- data_adults_baseline[grep('Female', data_adults_concentration$Gendername),]
	data_children_baseline_m <- data_children_baseline[grep('Male', data_children_baseline$Gendername),]
	data_children_baseline_f <- data_children_baseline[grep('Female', data_children_baseline$Gendername),]
	data_children_concentration_m <- data_children_concentration[grep('Male', data_children_concentration$Gendername),]
	data_children_concentration_f <- data_children_concentration[grep('Female', data_children_concentration$Gendername),]

	#Find variance vectors
	covariance_adults_baseline_m = var(data_adults_baseline_m[,2:129], na.rm = TRUE)
	covariance_adults_baseline_f = var(data_adults_baseline_f[,2:129], na.rm = TRUE)
	covariance_adults_concentration_m = var(data_adults_concentration_m[,2:129], na.rm = TRUE)
	covariance_adults_concentration_f = var(data_adults_concentration_f[,2:129], na.rm = TRUE)
	covariance_children_baseline_m = var(data_children_baseline_m[,2:129], na.rm = TRUE)
	covariance_children_baseline_f = var(data_children_baseline_f[,2:129], na.rm = TRUE)
	covariance_children_concentration_m = var(data_children_concentration_m[,2:129], na.rm = TRUE)
	covariance_children_concentration_f = var(data_children_concentration_f[,2:129], na.rm = TRUE)

	#Plot results with formatting
	name <- covariance_adults_baseline_m
	name <- melt(name)
	plot_results <- ggplot(name, aes(X1, X2)) + geom_tile(aes(fill = value),colour = "white") + scale_fill_gradient(low = "white", high = "steelblue")
	base_size <- 14
	print(plot_results + theme_grey(base_size = base_size) + labs(x = "", y = "") + scale_x_discrete(expand = c(0, 0)) + scale_y_discrete(expand = c(0, 0)) + theme(axis.ticks = element_blank(), axis.text.x = element_blank(),axis.text.y = element_blank(), legend.text = element_text(size = base_size)) + ggtitle("Male Adults Baseline Covariance Heatmap"))

	name <- covariance_adults_baseline_f
	name <- melt(name)
	plot_results <- ggplot(name, aes(X1, X2)) + geom_tile(aes(fill = value),colour = "white") + scale_fill_gradient(low = "white", high = "steelblue")
	print(plot_results + theme_grey(base_size = base_size) + labs(x = "", y = "") + scale_x_discrete(expand = c(0, 0)) + scale_y_discrete(expand = c(0, 0)) + theme(axis.ticks = element_blank(), axis.text.x = element_blank(),axis.text.y = element_blank(), legend.text = element_text(size = base_size)) + ggtitle("Female Adults Baseline Covariance Heatmap"))

	name <- covariance_adults_concentration_m
	name <- melt(name)
	plot_results <- ggplot(name, aes(X1, X2)) + geom_tile(aes(fill = value),colour = "white") + scale_fill_gradient(low = "white", high = "steelblue")
	print(plot_results + theme_grey(base_size = base_size) + labs(x = "", y = "") + scale_x_discrete(expand = c(0, 0)) + scale_y_discrete(expand = c(0, 0)) + theme(axis.ticks = element_blank(), axis.text.x = element_blank(),axis.text.y = element_blank(), legend.text = element_text(size = base_size)) + ggtitle("Male Adults Concentration Covariance Heatmap"))

	name <- covariance_adults_concentration_f
	name <- melt(name)
	plot_results <- ggplot(name, aes(X1, X2)) + geom_tile(aes(fill = value),colour = "white") + scale_fill_gradient(low = "white", high = "steelblue")
	print(plot_results + theme_grey(base_size = base_size) + labs(x = "", y = "") + scale_x_discrete(expand = c(0, 0)) + scale_y_discrete(expand = c(0, 0)) + theme(axis.ticks = element_blank(), axis.text.x = element_blank(),axis.text.y = element_blank(), legend.text = element_text(size = base_size)) + ggtitle("Female Adults Concentration Covariance Heatmap"))

	name <- covariance_children_baseline_m
	name <- melt(name)
	plot_results <- ggplot(name, aes(X1, X2)) + geom_tile(aes(fill = value),colour = "white") + scale_fill_gradient(low = "white", high = "steelblue")
	print(plot_results + theme_grey(base_size = base_size) + labs(x = "", y = "") + scale_x_discrete(expand = c(0, 0)) + scale_y_discrete(expand = c(0, 0)) + theme(axis.ticks = element_blank(), axis.text.x = element_blank(),axis.text.y = element_blank(), legend.text = element_text(size = base_size)) + ggtitle("Male Children Baseline Covariance Heatmap"))

	name <- covariance_children_baseline_f
	name <- melt(name)
	plot_results <- ggplot(name, aes(X1, X2)) + geom_tile(aes(fill = value),colour = "white") + scale_fill_gradient(low = "white", high = "steelblue")
	print(plot_results + theme_grey(base_size = base_size) + labs(x = "", y = "") + scale_x_discrete(expand = c(0, 0)) + scale_y_discrete(expand = c(0, 0)) + theme(axis.ticks = element_blank(), axis.text.x = element_blank(),axis.text.y = element_blank(), legend.text = element_text(size = base_size)) + ggtitle("Female Children Baseline Covariance Heatmap"))

	name <- covariance_children_concentration_m
	name <- melt(name)
	plot_results <- ggplot(name, aes(X1, X2)) + geom_tile(aes(fill = value),colour = "white") + scale_fill_gradient(low = "white", high = "steelblue")
	print(plot_results + theme_grey(base_size = base_size) + labs(x = "", y = "") + scale_x_discrete(expand = c(0, 0)) + scale_y_discrete(expand = c(0, 0)) + theme(axis.ticks = element_blank(), axis.text.x = element_blank(),axis.text.y = element_blank(), legend.text = element_text(size = base_size)) + ggtitle("Male Children Concentration Covariance Heatmap"))

	name <- covariance_children_concentration_f
	name <- melt(name)
	plot_results <- ggplot(name, aes(X1, X2)) + geom_tile(aes(fill = value),colour = "white") + scale_fill_gradient(low = "white", high = "steelblue")
	print(plot_results + theme_grey(base_size = base_size) + labs(x = "", y = "") + scale_x_discrete(expand = c(0, 0)) + scale_y_discrete(expand = c(0, 0)) + theme(axis.ticks = element_blank(), axis.text.x = element_blank(),axis.text.y = element_blank(), legend.text = element_text(size = base_size)) + ggtitle("Female Children Concentration Covariance Heatmap"))
}


#' High-Dimensional Regularized Discriminant Analysis (HDRDA)
#'
#' Given a set of training data, this function builds the HDRDA classifier from
#' Ramey, Stein, and Young (2017). Specially designed for small-sample,
#' high-dimensional data, the HDRDA classifier incorporates dimension reduction
#' and covariance-matrix shrinkage to enable a computationally efficient
#' classifier.
#'
#' The HDRDA classifier utilizes a covariance-matrix estimator that is a convex
#' combination of the covariance-matrix estimators used in the Linear
#' Discriminant Analysis (LDA) and Quadratic Discriminant Analysis (QDA)
#' classifiers. For each of the `K` classes given in `y`,
#' \eqn{(k = 1, \ldots, K)}, we first define this convex combination as
#' \deqn{\hat{\Sigma}_k(\lambda) = (1 - \lambda) \hat{\Sigma}_k
#' + \lambda \hat{\Sigma},}
#' where \eqn{\lambda \in [0, 1]} is the _pooling_ parameter. We then
#' calculate the covariance-matrix estimator
#' \deqn{\tilde{\Sigma}_k = \alpha_k \hat{\Sigma}_k(\lambda) + \gamma I_p,}
#' where \eqn{I_p} is the \eqn{p \times p} identity matrix. The matrix
#' \eqn{\tilde{\Sigma}_k} is substituted into the HDRDA classifier. See Ramey et
#' al. (2017) for more details.
#'
#' The matrix of training observations are given in `x`. The rows of
#' `x` contain the sample observations, and the columns contain the features
#' for each training observation. The vector of class labels given in `y`
#' are coerced to a `factor`. The length of `y` should match the number
#' of rows in `x`.
#'
#' The vector `prior` contains the _a priori_ class membership for
#' each class. If `prior` is `NULL` (default), the class membership
#' probabilities are estimated as the sample proportion of observations
#' belonging to each class. Otherwise, `prior` should be a vector with the
#' same length as the number of classes in `y`. The `prior`
#' probabilities should be nonnegative and sum to one. The order of the prior
#' probabilities is assumed to match the levels of `factor(y)`.
#'
#' @export
#' @references Ramey, J. A., Stein, C. K., and Young, D. M. (2017),
#' "High-Dimensional Regularized Discriminant Analysis."
#' \url{https://arxiv.org/abs/1602.01182}.
#' @references Friedman, J. H. (1989), "Regularized Discriminant Analysis,"
#' Journal of American Statistical Association, 84, 405, 165-175.
#' \url{http://www.jstor.org/pss/2289860} (Requires full-text access).
#' @inheritParams lda_diag
#' @param y vector of class labels for each training observation
#' @param lambda the HDRDA pooling parameter. Must be between 0 and 1,
#' inclusively.
#' @param gamma a numeric values used for the shrinkage parameter.
#' @param shrinkage_type the type of covariance-matrix shrinkage to apply. By
#' default, a ridge-like shrinkage is applied. If `convex` is given, then
#' shrinkage similar to Friedman (1989) is applied. See Ramey et al. (2017) for
#' details.
#' @param prior vector with prior probabilities for each class. If `NULL`
#' (default), then the sample proportion of observations belonging to each class
#' equal probabilities are used. See details.
#' @param tol a threshold for determining nonzero eigenvalues.
#' @return `rda_high_dim` object that contains the trained HDRDA classifier
rda_high_dim <- function(x, ...) {
  UseMethod("rda_high_dim")
}

#' @rdname rda_high_dim
#' @export
rda_high_dim.default <- function(x, y, lambda = 1, gamma = 0,
                                 shrinkage_type = c("ridge", "convex"), prior = NULL,
                                 tol = 1e-6, ...) {
  x <- pred_to_matrix(x)
  y <- outcome_to_factor(y)
  complete <- complete.cases(x) & complete.cases(y)
  x <- x[complete,,drop = FALSE]
  y <- y[complete]
  lambda <- as.numeric(lambda)
  gamma <- as.numeric(gamma)
  shrinkage_type <- match.arg(shrinkage_type)

  if (lambda < 0 || lambda > 1) {
    rlang::abort("The value for 'lambda' must be between 0 and 1, inclusively.")
  }

  if (gamma < 0) {
    rlang::abort("The value for 'gamma' must be nonnegative.")
  }

  obj <- regdiscrim_estimates(x = x, y = y, cov = FALSE, prior = prior, ...)
  x_centered <- center_data(x = x, y = y)
  K <- obj$num_groups

  # Computes the eigenvalue decomposition of the pooled sample covariance matrix
  # using the Fast SVD approach.
  cov_pool_eigen <- cov_eigen(x = x, y = y, pool = TRUE, fast = TRUE, tol = tol)

  obj$D_q <- cov_pool_eigen$values
  obj$U1 <- cov_pool_eigen$vectors
  obj$q <- length(obj$D_q)
  obj$shrinkage_type <- shrinkage_type
  obj$lambda <- lambda
  obj$gamma <- gamma

  if (shrinkage_type == "ridge") {
    alpha <- 1
  } else {
    # shinkage_family == "convex"
    alpha <- 1 - gamma
  }

  # Transforms the centered data
  XU <- x_centered %*% obj$U1

  # For each class, we calculate the following quantities necessary to train the
  # HDRDA classifier.
  #   1. \Gamma_k
  #   2. Q_k
  #   3. W_k^{-1}
  for (k in seq_len(K)) {
    X_k <- x_centered[y == levels(y)[k], , drop=FALSE]
    n_k <- nrow(X_k)

    # Extracts the transformed, centered data
    # No need to calculate it for the classes individually
    XU_k <- XU[y == levels(y)[k], , drop=FALSE]

    # Transforms the sample mean to the lower dimension
    xbar_U1 <- crossprod(obj$U1, obj$est[[k]]$xbar)

    # In the special case that (lambda, gamma) = (0, 0), the improvements to
    # HDRDA's speed via the Sherman-Woodbury formula are not applicable because
    # Gamma = 0. In this case, we calculate W_inv directly. If the matrix is
    # singular, a slight amount of shrinkage is applied.
    if (lambda == 0 && gamma == 0) {
      W_k <- cov_mle(XU_k)
      W_inv <- try(solve_chol(W_k), silent=TRUE)

      if (inherits(W_inv, "try-error")) {
        W_k <- W_k + diag(0.001, nrow=nrow(W_k), ncol=ncol(W_k))
        W_inv <- solve_chol(W_k)
      }

      Gamma <- matrix(0, nrow=obj$q, ncol=obj$q)
      Q <- diag(n_k)
    } else {
      # Although 'Gamma_k' is a diagonal matrix, we store only its diagonal
      # elements.
      Gamma <- alpha * lambda * obj$D_q + gamma
      Gamma_inv <- diag(Gamma^(-1))

      # X_k %*% U_1 %*% Gamma^{-1} is computed repeatedly in the equations.
      # We compute the matrix once and use it where necessary to avoid
      # unnecessary computations.
      XU_Gamma_inv <- XU_k %*% Gamma_inv
      Q <- diag(n_k) + alpha * (1 - lambda) / n_k * tcrossprod(XU_Gamma_inv, XU_k)
      W_inv <- alpha * (1 - lambda) / n_k * crossprod(XU_Gamma_inv, solve(Q, XU_Gamma_inv))
      W_inv <- Gamma_inv - W_inv
    }

    obj$est[[k]]$n_k <- n_k
    obj$est[[k]]$alpha <- alpha
    obj$est[[k]]$XU <- XU_k
    obj$est[[k]]$xbar_U1 <- xbar_U1
    obj$est[[k]]$Gamma <- Gamma
    obj$est[[k]]$Q <- Q
    obj$est[[k]]$W_inv <- W_inv
  }

  # Creates an object of type 'rda_high_dim'
  obj$col_names <- colnames(x)
  obj <- new_discrim_object(obj, "rda_high_dim")

  obj
}

#' @inheritParams lda_diag
#' @rdname rda_high_dim
#' @importFrom stats model.frame model.matrix model.response
#' @export
rda_high_dim.formula <- function(formula, data, ...) {
  # The formula interface includes an intercept. If the user includes the
  # intercept in the model, it should be removed. Otherwise, errors and doom
  # happen.
  # To remove the intercept, we update the formula, like so:
  # (NOTE: The terms must be collected in case the dot (.) notation is used)
  formula <- no_intercept(formula, data)

  mf <- model.frame(formula = formula, data = data)
  .terms <- attr(mf, "terms")
  x <- model.matrix(.terms, data = mf)
  y <- model.response(mf)

  est <- rda_high_dim.default(x = x, y = y, ...)
  est$.terms <- .terms
  est <- new_discrim_object(est, class(est))
  est
}

#' Outputs the summary for a HDRDA classifier object.
#'
#' Summarizes the trained rda_high_dim classifier in a nice manner.
#'
#' @param x object to print
#' @param ... unused
#' @keywords internal
#' @export
print.rda_high_dim <- function(x, ...) {
  cat("High-Dimensional Regularized Discriminant Analysis\n\n")
  print_basics(x, ...)
  cat("\nReduced dimension:", x$q, "\n")
  cat("Shrinkage type:", x$shrinkage_type, "\n")
  cat("Lambda:", signif(x$lambda, 3), "Gamma:", signif(x$gamma, 3), "\n")
  invisible(x)
}

#' Predicts the class membership of a matrix of unlabeled observations with a
#' trained HDRDA classifier.
#'
#' For a given `rda_high_dim` object, we predict the class of each observation
#' (row) of the the matrix given in `newdata`.
#'
#' @rdname rda_high_dim
#' @inheritParams predict.lda_diag
#' @export
#' @param object Object of type `rda_high_dim` that contains the trained HDRDA
#' classifier
#' @param projected logical indicating whether `newdata` have already been
#' projected to a q-dimensional subspace. This argument can yield large gains in
#' speed when the linear transformation has already been performed.
#' @return list with predicted class and discriminant scores for each of the K
#' classes
predict.rda_high_dim <- function(object, newdata, projected = FALSE, type = c("class", "prob", "score"), ...) {
  type <- rlang::arg_match0(type, c("class", "prob", "score"), arg_nm = "type")
  newdata <- process_newdata(object, newdata)

  scores <- sapply(object$est, function(class_est) {
    if (object$lambda == 0 && object$gamma == 0) {
      # Want: log(det(W_k)) = -log(det(W_k_inv))
      log_det <- -log_determinant(class_est$W_inv)
    } else {
      log_det <- log_determinant(class_est$Q)
    }

    if (projected) {
      # The newdata have already been projected. Yay for speed!
      # Center the 'newdata' by the projected class sample mean
      U1_x <- scale(newdata, center = class_est$xbar_U1, scale = FALSE)

      quad_forms <- diag(drop(tcrossprod(U1_x %*% class_est$W_inv, U1_x)))
    } else {
      # Center the 'newdata' by the class sample mean
      x_centered <- scale(newdata, center = class_est$xbar, scale = FALSE)

      U1_x <- crossprod(object$U1, t(x_centered))

      quad_forms <- apply(U1_x, 2, function(z) {
        quadform(class_est$W_inv, z)
      })
    }

    quad_forms + log_det - 2 * log(class_est$prior)
  })

  if (is.vector(scores)) {
    # When sapply above returns a vector, the naming is thrown off.
    # Hence, we rename it to the groups.
    names(scores) <- object$groups

    min_scores <- min_index(scores)
    posterior <- exp(-(scores - min(scores)))
    posterior <- posterior / sum(posterior)
  } else {
    min_scores <- apply(scores, 1, min_index)
    # Grabbed code to calculate 'posterior' from MASS:::predict.qda, which
    # handles numerical overflow unlike the more direct:
    # exp(scores) / (1 + exp(sum(scores)))
    posterior <- exp(-(scores - apply(scores, 1, min)))
    posterior <- posterior / rowSums(posterior)
  }

  if (type == "prob") {
    if (is.vector(posterior)) {
      posterior <- matrix(posterior, nrow = 1)
      colnames(posterior) <- object$groups
    }
    res <- as.data.frame(posterior)
  } else if (type == "class") {
    res <- with(object, factor(groups[min_scores], levels = groups))
  } else {
    if (is.vector(scores)) {
      scores <- matrix(scores, nrow = 1)
      colnames(scores) <- object$groups
    }
    res <- as.data.frame(scores)
  }
  res
}

#' Helper function to optimize the HDRDA classifier via cross-validation
#'
#' For a given data set, we apply cross-validation (cv) to select the optimal
#' HDRDA tuning parameters.
#'
#' The number of cross-validation folds is given in `num_folds`.
#'
#' @export
#' @importFrom dplyr arrange
#' @inheritParams lda_diag
#' @param y vector of class labels for each training observation
#' @param num_folds the number of cross-validation folds.
#' @param num_lambda The number of values of `lambda` to consider
#' @param num_gamma The number of values of `gamma` to consider
#' @param shrinkage_type the type of covariance-matrix shrinkage to apply. By
#' default, a ridge-like shrinkage is applied. If `convex` is given, then
#' shrinkage similar to Friedman (1989) is applied. See Ramey et al. (2017) for
#' details.
#' @param verbose If set to `TRUE`, summary information will be outputted
#' as the optimal model is being determined.
#' @param ... Options passed to [rda_high_dim()].
#' @return list containing the HDRDA model that minimizes cross-validation as
#' well as a `data.frame` that summarizes the cross-validation results.
rda_high_dim_cv <- function(x, y, num_folds = 10, num_lambda = 21, num_gamma = 8,
                            shrinkage_type=c("ridge", "convex"), verbose=FALSE, ...) {
  x <- pred_to_matrix(x)
  y <- outcome_to_factor(y)
  complete <- complete.cases(x) & complete.cases(y)
  x <- x[complete,,drop = FALSE]
  y <- y[complete]
  shrinkage_type <- match.arg(shrinkage_type)

  cv_folds <- cv_partition(y = y, num_folds = num_folds)

  # The grid of tuning parameters
  # We sort the grid by model preference. Models with lambda = 0 are most
  # preferred because they assume that the covariance matrices are equal. This
  # preference is further based on model parsimony.
  seq_lambda <- seq(0, 1, length = num_lambda)

  if (shrinkage_type == "ridge") {
    seq_gamma <- c(0, 10^seq.int(-2, num_gamma - 4))
  } else  {
    # shrinkage_type == "convex"
    seq_gamma <- seq(0, 1, length = num_gamma)
  }

  tuning_grid <- expand.grid(lambda = seq_lambda, gamma = seq_gamma)
  tuning_grid <- dplyr::arrange(tuning_grid, lambda, gamma)

  cv_errors <- sapply(seq_along(cv_folds), function(fold_i) {
    if (verbose) {
      cat("CV Fold: ", fold_i, " of ", num_folds, "\n")
    }
    fold <- cv_folds[[fold_i]]
    train_x <- x[fold$training, ]
    train_y <- y[fold$training]
    test_x <- x[fold$test, ]
    test_y <- y[fold$test]

    hdrda_out <- rda_high_dim(x = train_x, y = train_y, lambda = 1, gamma = 0, ...)

    # Projects the test data to the q-dimensional subspace.
    # No need to do this for each lambda/gamma pair.
    # NOTE: It's not centered yet.
    test_x <- test_x %*% hdrda_out$U1

    # For each value of lambda and gamma, we train the HDRDA classifier,
    # classify the test observations, and record the number of classification
    # errors.
    fold_errors <- mapply(function(lambda, gamma) {
      errors <- try({
        # Updates Gamma, Q, and W_inv for each class in hdrda_out
        # If an error is thrown, we return 'NA'.
        hdrda_updated <- update_rda_high_dim(hdrda_out, lambda, gamma)
        # Call to predict.rda_high_dim is explicit to pass R CMD CHECK.
        sum(predict.rda_high_dim(hdrda_updated, test_x, projected = TRUE)$class != test_y)
      }, silent = TRUE)

      errors
    }, tuning_grid$lambda, tuning_grid$gamma)
    fold_errors
  })
  cv_errors <- rowSums(cv_errors)
  error_rate <- cv_errors / nrow(x)

  cv_summary <- cbind(tuning_grid, cv_errors, error_rate)

  optimal <- which.min(cv_errors)
  lambda <- tuning_grid$lambda[optimal]
  gamma <- tuning_grid$gamma[optimal]

  # Trains a classifier based on optimal model
  hdrda_out <- rda_high_dim(x=x, y=y, lambda=lambda, gamma=gamma,
                            shrinkage_type=shrinkage_type)

  # Adds optimal parameters and cv_summary to classifier object
  hdrda_out$lambda <- lambda
  hdrda_out$gamma <- gamma
  hdrda_out$cv_summary <- cv_summary
  class(hdrda_out) <- c("hdrda_cv", "rda_high_dim")

  hdrda_out
}

#' Plots a heatmap of cross-validation error grid for a HDRDA classifier object.
#'
#' Uses [ggplot2::ggplot2()] to plot a heatmap of the training error
#' grid.
#'
#' @param x object to plot
#' @param ... unused
#' @export
#' @importFrom ggplot2 ggplot aes scale_fill_gradient labs scale_x_discrete
#' @importFrom ggplot2 scale_y_discrete theme labs geom_tile element_blank
plot.rda_high_dim_cv <- function(x, ...) {
  cv_summary <- x$cv_summary
  cv_summary <- within(cv_summary, {
    lambda <- round(lambda, 3)
    gamma <- round(gamma, 3)
  })

  # Fixes NOTE from R CMD CHECK
  # "no visible binding for global variable 'error_rate'"
  error_rate <- 1

  p <- ggplot(cv_summary, aes(factor(gamma), factor(lambda)))
  p <- p + geom_tile(aes(fill=error_rate), colour="white")
  p <- p + scale_fill_gradient(low="white",
                               high="steelblue",
                               name="CV Error Rate")
  p <- p + labs(x=expression(gamma), y=expression(lambda))
  p <- p + scale_x_discrete(expand=c(0, 0))
  p <- p + scale_y_discrete(expand=c(0, 0))
  p <- p + theme(axis.ticks=element_blank())
  p
}

#' Helper function to update tuning parameters for the HDRDA classifier
#'
#' This function updates some of the quantities in the HDRDA classifier based on
#' updated values of `lambda` and `gamma`. The update can greatly
#' expedite cross-validation to examine a large grid of values for `lambda`
#' and `gamma`.
#'
#' @param obj a `rda_high_dim` object
#' @param lambda a numeric value between 0 and 1, inclusively
#' @param gamma a numeric value (nonnegative)
#' @return a `rda_high_dim` object with updated estimates
update_rda_high_dim <- function(obj, lambda = 1, gamma = 0) {
  # In the special case that (lambda, gamma) = (0, 0), the improvements to
  # HDRDA's speed via the Sherman-Woodbury formula are not applicable because
  # Gamma = 0. In this case, we calculate W_inv directly.
  if (lambda == 0 && gamma == 0) {
    Gamma <- matrix(0, nrow=obj$q, ncol=obj$q)
  } else {
    # NOTE: alpha_k is constant across all classes, so that alpha_k = alpha_1
    # for all k. As a result, Gamma and Gamma_inv are constant across all k. We
    # compute both before looping through all K classes.
    Gamma <- obj$est[[1]]$alpha * lambda * obj$D_q + gamma
    Gamma_inv <- diag(Gamma^(-1))
  }

  for (k in seq_len(obj$num_groups)) {
    n_k <- obj$est[[k]]$n_k
    if (lambda == 0 && gamma == 0) {
      Q <- diag(n_k)

      W_k <- cov_mle(obj$est[[k]]$XU)
      W_inv <- try(solve_chol(W_k), silent=TRUE)
      if (inherits(W_inv, "try-error")) {
        W_k <- W_k + diag(0.001, nrow=nrow(W_k), ncol=ncol(W_k))
        W_inv <- solve_chol(W_k)
      }
    }
    else {
      # X_k %*% U_1 %*% Gamma^{-1} is computed repeatedly in the equations.
      # We compute the matrix once and use it where necessary to avoid
      # unnecessary computations.
      XU_Gamma_inv <- obj$est[[k]]$XU %*% Gamma_inv
      Q <- diag(n_k) +
        obj$est[[k]]$alpha * (1 - lambda) / n_k * tcrossprod(XU_Gamma_inv, obj$est[[k]]$XU)

      W_inv <- obj$est[[k]]$alpha * (1 - lambda) / n_k *
        crossprod(XU_Gamma_inv, solve(Q, XU_Gamma_inv))
      W_inv <- Gamma_inv - W_inv
    }
    obj$est[[k]]$Gamma <- Gamma
    obj$est[[k]]$Q <- Q
    obj$est[[k]]$W_inv <- W_inv
  }
  obj$lambda <- lambda
  obj$gamma <- gamma
  obj
}


library(npowerPrioR)
source("data_cure_rate_real.r")

####################
J <- 20

adaptive.ca0.estimates <- read.csv(paste0("../../data/constant_data/CureRateRealData_logCA0_adaptive_J=", J, ".csv"))

maxA <- max(adaptive.ca0.estimates$a0)

#######

midpoint_integrate_la0 <- function(x_preds, fit){
  ## takes a grid of values for the input and a fit object that gives predictions (GLM, GAM, etc) and
  ## Gives the integrated function
  n <- length(x_preds)
  delta <- (x_preds[2]-x_preds[1])
  midpoints <- 0.5*(x_preds[2:n] + x_preds[1:(n-1)])
  ans <-  cumsum(predict(fit, newdata = data.frame(a0 = midpoints))) * delta
  ans <- c(0, ans)
  return(ans)
}

fit.gam <- mgcv::gam(lc_a0 ~ s(a0, k = J + 1), data = adaptive.ca0.estimates)
deriv.gam.fit <- mgcv::gam(deriv_lc ~ s(a0, k = J), data = adaptive.ca0.estimates[-1, ])

K <- 20000
pred_a0s <- seq(0, maxA, length.out = K)

preds.gam  <- get_band(fit.gam, xpred = pred_a0s)
deriv.preds <- midpoint_integrate_la0(pred_a0s, deriv.gam.fit)

gam.preds.list <- list(
  gam =  data.frame (a0 = pred_a0s, lca0 = preds.gam$mean, lwr = preds.gam$lwr,
                     upr = preds.gam$upr, approximating_function = "gam", design = "adaptive"),
  derivative = data.frame (a0 = pred_a0s, lca0 = deriv.preds, lwr = NA, upr = NA,
                           approximating_function = "gam-derivative", design = "adaptive_numerical")
)

forplot_ca0 <- do.call(rbind, gam.preds.list)

write.csv(forplot_ca0, file = "../../data/constant_data/fitted_predictions_lca0_CureRateSimuData.csv",  row.names = FALSE)

### Plotting

library(ggplot2)

p0 <- ggplot(data = forplot_ca0, aes(x = a0, y = lca0, colour = approximating_function, fill = approximating_function)) +
  geom_line() +
  geom_ribbon(aes(min = lwr, max = upr), alpha = .4) +
  geom_point(data = adaptive.ca0.estimates, mapping = aes(x = a0, y = lc_a0), colour = "black", alpha = .4, size = 5, inherit.aes = FALSE) +
  scale_x_continuous(expression(a[0])) +
  scale_y_continuous(expression(log(c(a[0])))) +
  theme_bw(base_size = 16)
p0

ggsave(p0, filename = "../figures/estimates_log_ca0_CureRateRealData.pdf", dpi = 300)

####
## Sensitivity analysis
sens.analysis.dt <- do.call(rbind, lapply(1:length(adaptive.ca0.estimates$summaries), function(i) {
  y <- data.frame(adaptive.ca0.estimates$summaries[[i]])
  y$a_0 <- adaptive.ca0.estimates$result$a0[i]
  return(y)
})
)

p1 <- ggplot(data = sens.analysis.dt, aes(x = a_0, y = mean, fill = parameter, colour = parameter)) +
  geom_line() +
  geom_ribbon(aes(min = lwr, max = upr), alpha = .4) +
  scale_x_continuous(expression(a[0]), expand = c(0, 0), limit = c(0, 1)) +
  scale_y_continuous("", expand = c(0, 0)) +
  facet_grid(parameter~., labeller = label_parsed, scales = "free")+
  theme_bw(base_size = 16)
p1

ggsave(p1, filename = "../figures/sensitivity_CureRateRealData.pdf", dpi = 300)

p1b <- ggplot(data = subset(sens.analysis.dt, a_0  < 0.2), aes(x = a_0, y = mean, fill = parameter, colour = parameter)) +
  geom_line() +
  geom_ribbon(aes(min = lwr, max = upr), alpha = .4) +
  scale_x_continuous(expression(a[0]), expand = c(0, 0)) +
  scale_y_continuous("", expand = c(0, 0)) +
  facet_grid(parameter~., labeller = label_parsed, scales = "free")+
  theme_bw(base_size = 16)
p1b

p1c <- ggplot(data = subset(sens.analysis.dt, a_0 > 0.2), aes(x = a_0, y = mean, fill = parameter, colour = parameter)) +
  geom_line() +
  geom_ribbon(aes(min = lwr, max = upr), alpha = .4) +
  scale_x_continuous(expression(a[0]), expand = c(0, 0)) +
  scale_y_continuous("", expand = c(0, 0)) +
  facet_grid(parameter~., labeller = label_parsed, scales = "free")+
  theme_bw(base_size = 16)
p1c


# script can be executed with

library(readr)
library(ggplot2)
library(dplyr)
library(lubridate)
library(gganimate)

temps = read_csv("saxony-monthly-temperature.csv")

#find common stations from 1951 - 2017
stats51 = temps %>%
    mutate(yr= as.integer(year(ymd(MESS_DATUM_BEGINN))),
           mo= as.integer(month(ymd(MESS_DATUM_BEGINN)))) %>%
    filter(yr == 1951, mo == 7)

stats17 = temps %>%
    mutate(yr= as.integer(year(ymd(MESS_DATUM_BEGINN))),
           mo= as.integer(month(ymd(MESS_DATUM_BEGINN)))) %>%
    filter(yr == 2017, mo == 7)

#find stations that are common in both years
common = intersect(stats51$STATIONS_ID,stats17$STATIONS_ID)

#crosscheck
cat(paste(common))

stations = temps %>%
    select(STATIONS_ID, geo_lat, geo_lon, height)%>%
    unique()

#compute median of reference years 1951 to 1981
ref_median_year = temps %>%
    mutate(yr= as.integer(year(ymd(MESS_DATUM_BEGINN))),
           mo= as.integer(month(ymd(MESS_DATUM_BEGINN)))) %>%
    filter(yr > 1950 & yr < 1982, ! is.na(MO_TT), STATIONS_ID %in% common) %>%
    group_by(STATIONS_ID, mo) %>%
  summarize( refmedian = median(MO_TT), refmax = median(MO_TX), refmin = median(MO_TN))

                                        #TODO: add german map
#https://nceas.github.io/oss-lessons/spatial-data-gis-law/3-mon-intro-gis-in-r.html
temps_station = temps %>%
    mutate(yr= as.integer(year(ymd(MESS_DATUM_BEGINN))), mo= month(ymd(MESS_DATUM_BEGINN))) %>%
    filter(yr > 1945, ! is.na(MO_TT) , STATIONS_ID %in% common) %>%
    left_join(ref_median_year, by=c('STATIONS_ID' = 'STATIONS_ID', 'mo' = 'mo')) %>%
  mutate( anom = MO_TT - refmedian,
         max_anom = MO_TX - refmax ,
         min_anom = MO_TN - refmin ) %>%
    group_by(STATIONS_ID,yr) %>%
    summarize( anom_total     = round(sum(anom),0),
              max_anom_total = round(sum(max_anom),0),
              min_anom_total = round(sum(min_anom),0),
              anom_median_rounded    = round(median(anom),0),
              anom_median    = median(anom),
              max_anom_median= round(median(max_anom),0),
              min_anom_median= round(median(min_anom),0)
              ) %>%
    left_join(stations, by=c('STATIONS_ID' = 'STATIONS_ID'))

nyears = length(unique(temps_station$yr))
sac <- sf::st_read("shapes/vg2500_bld.shp", quiet = TRUE)  %>% filter(GEN %in% "Sachsen")

# https://github.com/thomasp85/gganimate
anplot = ggplot(sac) +
  geom_sf() +
  geom_point(data=temps_station,aes(x=geo_lon,
                                    y=geo_lat,
                                    color=anom_median_rounded,
                                    size=abs(anom_median)*50)) +
    theme_minimal() +
    scale_color_gradient2(midpoint=0, low="blue", mid="white",
                           high="red", space ="Lab" ) +
    xlab("Monat") +
    ylab("Durchschnitstemperatur") +
  labs(title = 'Jahr: {frame_time}, Anomalie der Monatsmitteltemperatur im Jahr (Referenz 1950-1981)',
       caption = 'Datenquelle: DWD, Code: https://github.com/psteinb/citizenscience-climatechange-saxony',
       x = 'Länge',
       y = 'Breite') +
  guides(size = "none", color= guide_legend(title = "Anomaliewert")) +
  transition_time(yr) +
  ease_aes('cubic-in-out')

anim = animate(anplot,
               nframes=3*nyears,
               duration=20,
               renderer = gifski_renderer(),
               width=700,
               height=500,
               end_pause=20)

anim_save("monthly-temperatures.gif",anim)

anplot = ggplot(sac) +
  geom_sf() +
  geom_point(data=temps_station,aes(x=geo_lon,
                                    y=geo_lat,
                                    color=min_anom_median,
                                    size=abs(min_anom_median)*30)) +
    theme_minimal() +
    scale_color_gradient2(midpoint=0, low="blue", mid="white",
                           high="red", space ="Lab" ) +
    xlab("Monat") +
    ylab("Durchschnitstemperatur") +
    labs(title = 'Jahr: {frame_time}, Anomalie der Monatsmindesttemperatur im Jahr (Referenz 1950-1981)',
         caption = 'Datenquelle: DWD, Code: https://github.com/psteinb/citizenscience-climatechange-saxony',
         x = 'Länge', y = 'Breite') +
  guides(size = "none", color= guide_legend(title = "Anomaliewert")) +
    transition_time(yr) +
  ease_aes('cubic-in-out')

anim = animate(anplot,
               nframes=nyears,
               duration=20,
               renderer = gifski_renderer(),
               width=700,
               height=500,
               end_pause=20)
#magick::image_write(anim, path="monthly-temperatures.gif")
anim_save("monthly-min-temperatures.gif",anim)


x <- c(2,7,1,-17,NA,Inf,35,21)
rank(x) #use Rank function in R with NAs as last
rank(-x) #use Rank function in R with NAs as first

R Community/R functions Assignments/Assignment1.r


library(data.table)

data <- fread("../data/train_numeric.csv",select = c("Id", "Response"));
data <- data[,c('Id', 'Response')];
data$nextId = data$Id + 1;
IdList <- data[data$nextId %in% data$Id];

data[Id %in% IdList$Id] -> current;
data[Id %in% IdList$nextId] -> nextId;

prob = table(current$Response,nextId$Response);

prob1 = prob[2,2]/(prob[2,1]+prob[2,2]);
prob2 = prob[2,1]/(prob[1,1]+prob[2,1]);

print("Percentage of defect after defect");
print(prob1);

print("Percentage of defect after no defect");
print(prob2);


R version 3.2.3 (2015-12-10) -- "Wooden Christmas-Tree"
Copyright (C) 2015 The R Foundation for Statistical Computing
Platform: x86_64-w64-mingw32/x64 (64-bit)

R is free software and comes with ABSOLUTELY NO WARRANTY.
You are welcome to redistribute it under certain conditions.
Type 'license()' or 'licence()' for distribution details.

R is a collaborative project with many contributors.
Type 'contributors()' for more information and
'citation()' on how to cite R or R packages in publications.

Type 'demo()' for some demos, 'help()' for on-line help, or
'help.start()' for an HTML browser interface to help.
Type 'q()' to quit R.

[Workspace loaded from ~/.RData]

 NASA = read.csv("d:/NASAUnderstory.csv",header=T)
 NASA.lab=NASA$Labels
 NASA.lab
 NASA=NASA[,-32]
 NASA

 NASAscale<-scale(NASA[,3:31])
 NASAscale

 rownames(NASAscale)=as.factor(NASA$Overstory.Species)
 rownames(NASAscale)

 dist1<-dist(NASAscale, method="euclidean")

 clust1<-hclust(dist1,method="ward.D")
 clust1

 plot(clust1,labels= NASA[,2], cex=0.5, xlab="",ylab="Distance",main="Clustering for NASA Understory Data")

 rect.hclust(clust1,k=2)

 cuts=cutree(clust1,k=2)

 cuts

 library(vegan)

 dist1<-vegdist(NASA[,3:31], method="jaccard", upper=T)
 clust1<-hclust(dist1,method="ward.D")

 clust1

 plot(clust1,labels= NASA[,2], cex=0.5, xlab="",ylab="Distance",main="Clustering for NASA Understory Data")
 rect.hclust(clust1,k=2)
 cuts=cutree(clust1,k=2)
 cuts

 clusplot(NASA, cuts, color=TRUE, shade=TRUE, labels=2, lines=0,
          main="NASA Two Cluster Plot, Ward's Method, First two PC")

 library(fpc)
 NASAtrans=t(NASAscale)

 dist1<-dist(NASAtrans, method="minkowski", p=3)

 clust1<-hclust(dist1,method="ward.D")
 clust1

 plot(clust1,labels= NASA.lab[1:29], cex=1, xlab="",ylab="Distance",main="Clustering for NASA Understory Data")
 rect.hclust(clust1,k=3)

Chapter 03/2Hierarchical Clustering - NASA Under story.r


# two-way ANOVA for cob compressive data
library(car)

data <- read.csv("SizeExperimentBending.txt",sep="\t")
# print(data)

# print(Anova(lm(Strength ~ Clay*Straw, data), type="3"))
print(anova(lm(Peak ~ Batch*Size, data)))


library(FinancialMath)

# liczba dotad splaconych rat
lba_splaconych_rat <- 174

# wektor liczby dni w miesiacu: rok zwykly
dni_w_roku <- c(31, 28, 31, 30, 31, 30, 31, 31, 30, 31, 30, 31)

# wektor liczby dni w miesiacu: rok przestepny
dni_w_roku_p <- replace(dni_w_roku, dni_w_roku==28, 29)

# wektor liczby dni w miesiacu dla kolejnej raty
wek_dni_w_mies <- c(dni_w_roku[7:12], rep(c(dni_w_roku, dni_w_roku_p, dni_w_roku, dni_w_roku), length.out=353))

# wektor liczby dni w roku dla kolejnej raty
wek_dni_w_roku <- c(rep(365, times=6), rep(rep(c(365,366,365,365), each=12), length.out=353))

# na podstawie § 11 ust 7 rok liczy zawsze 365 dni
dni_w_roku_sum <- sum(dni_w_roku)

# wektory z wysokoscia rat pobranych przez mBank
raty_pobrane <- rep(c(479.42, 334.69, 306.84, 306.83, 306.84, 318.53, 330.45, 342.35, 332.86, 327.42, 316.68, 290.48), times=c(1,1,1,1,1,2,6,20,10,6,55,70))

# wczytanie danych z kursami walut
kursy_walut <- read.csv('~/R/mBank/kursy_walut.csv', header = TRUE)

# daty ksiegowania rat
data_ksiegowania <- as.vector(kursy_walut$data)

##########################################
#
#               rata #1
#
##########################################
kapital_poczatkowy <- 72161.65
oprocentowanie <- 3.45
poz_lba_rat <- 359
dni_w_mcu <- c("cze" = 23, "lip" = 31)
##########################################
cat("-----------  rata #1  -----------\n")

# wyliczenie raty kapitalowo-odsetkowej wylacznie w miesiacu lipcu
oprocentowanie <- oprocentowanie / 100
rata_calkowita <- amort.period(Loan = kapital_poczatkowy, n = poz_lba_rat, i = oprocentowanie, ic = 12, pf = 12)
rata_calkowita <- round(rata_calkowita[2], digits = 2)

# wyliczenie raty odsetkowej: suma odsetek w miesiącach czerwiec oraz lipiec
rata_odsetkowa <- dni_w_mcu / dni_w_roku_sum * kapital_poczatkowy * oprocentowanie
cat("rata_odsetkowa[1] =", round(sum(rata_odsetkowa), digits = 2), "\n")

# wyliczenie raty kapitalowej
rata_kapitalowa <- rata_calkowita - round(as.vector(rata_odsetkowa["lip"]), digits = 2)
cat("rata_kapitalowa[1] =", rata_kapitalowa, "\n")

# kapital pozostajacy do splaty po racie #1
kapital <- kapital_poczatkowy - rata_kapitalowa
cat("kapital_do_splaty[1] =", kapital, "\n\n")

harmonogram <- data.frame(termin_splaty = data_ksiegowania[1],
                          kwota_kapitalu = as.vector(rata_kapitalowa),
                          kwota_odsetek = round(sum(rata_odsetkowa), digits = 2),
                          kwota_raty_lacznie = rata_calkowita + round(as.vector(rata_odsetkowa["cze"]), digits = 2),
                          saldo_zadluzenia_po_splacie_raty = kapital,
                          nadplata = 0)

##########################################
#
#               rata #2
#
##########################################
oprocentowanie <- c(3.45,2.45)
oprocentowanie_mB <- 3.75       # oprocentowanie ustalone przez mBank
dni_oprocentowania <- c(1,30)   # jeden dzień z oprocentowaniem 3,45% oraz 30 dni z oprocentowaniem 2,45%
poz_lba_rat <- 358
##########################################
cat("-----------  rata #2  -----------\n")

# wyliczenie raty calkowitej
oprocentowanie <- oprocentowanie / 100
dni_oprocentowania <- dni_oprocentowania / dni_w_roku_sum
rata_calkowita <- amort.period(Loan = kapital, n = poz_lba_rat, i = oprocentowanie[1], ic = 12, pf = 12)
rata_calkowita <- round(rata_calkowita[2], digits = 2)

# wyliczenie raty odsetkowej
rata_odsetkowa <- sum(kapital * oprocentowanie * dni_oprocentowania)
rata_odsetkowa <- round(rata_odsetkowa, digits = 2)
cat("rata_odsetkowa[2] =", rata_odsetkowa, "\n")

# wyliczenie raty kapitalowej
rata_kapitalowa <- rata_calkowita - rata_odsetkowa
cat("rata_kapitalowa[2] =", rata_kapitalowa, "\n")

# kapital pozostajacy do splaty po racie #2
kapital_mB <- kapital
kapital <- kapital - rata_kapitalowa
cat("kapital_do_splaty[2] =", kapital, "\n")

# wyliczenie nadplaty
oprocentowanie_mB <- oprocentowanie_mB / 100
rata_calkowita_mB <- amort.period(Loan = kapital_mB, n = poz_lba_rat, i = oprocentowanie_mB, ic = 12, pf = 12)
rata_calkowita_mB <- round(rata_calkowita_mB[2], digits = 2)
nadplata <- rata_calkowita_mB - rata_calkowita
cat("nadplata[2] =", nadplata, "\n\n")

harmonogram <- rbind(harmonogram, data.frame(termin_splaty = data_ksiegowania[2],
                                             kwota_kapitalu = rata_kapitalowa,
                                             kwota_odsetek = rata_odsetkowa,
                                             kwota_raty_lacznie = rata_calkowita,
                                             saldo_zadluzenia_po_splacie_raty = kapital,
                                             nadplata = nadplata))

##########################################
#
#           rata #3 i kolejne
#
##########################################
oprocentowanie = 2.45
poz_lba_rat <- 357
##########################################
cat("----------  rata #3 +  ----------\n")

# wyliczenie raty calkowitej
oprocentowanie <- oprocentowanie / 100
rata_calkowita <- amort.period(Loan = kapital, n = poz_lba_rat, i = oprocentowanie, ic = 12, pf = 12)
rata_calkowita <- round(rata_calkowita[2], digits = 2)
cat("rata_calkowita =", rata_calkowita, "\n\n")

# wyliczenie pozostalej czesci harmonogramu
for(rata in 3:359) {
  rata_odsetkowa <- round(kapital * oprocentowanie * wek_dni_w_mies[rata] / dni_w_roku_sum, digits = 2)
  rata_kapitalowa <- rata_calkowita - rata_odsetkowa
  kapital <- kapital - rata_kapitalowa

  harmonogram <- rbind(harmonogram, data.frame(termin_splaty = data_ksiegowania[rata],
                                               kwota_kapitalu = rata_kapitalowa,
                                               kwota_odsetek = rata_odsetkowa,
                                               kwota_raty_lacznie = rata_calkowita,
                                               saldo_zadluzenia_po_splacie_raty = kapital,
                                               nadplata = raty_pobrane[rata] - rata_calkowita))
}

cat("-----  stan na 01.01.2021  -----\n")
splacony_kapital <- sum(harmonogram$kwota_kapitalu[1:lba_splaconych_rat])
kapital_do_splaty <- kapital_poczatkowy - splacony_kapital
cat("splacony_kapital =", splacony_kapital, "\n")
cat("kapital_do_splaty =", kapital_do_splaty, "\n")

##########################################
#
#         wyliczenie nadplaty
#
##########################################
# raty 1 do 82 liczone po kursie mBanku
nadplata_PLN_mBank <- round(harmonogram$nadplata[1:82] * kursy_walut$kurs.mBank[1:82], digits = 2)

# od raty 83 splata bezposrednio w CHF, nadplata liczona po kursie srednim NBP
nadplata_PLN_NBP <- round(harmonogram$nadplata[83:lba_splaconych_rat] * kursy_walut$kurs.NBP[83:lba_splaconych_rat], digits = 2)

nadplata_PLN <- c(nadplata_PLN_mBank, nadplata_PLN_NBP)
cat("nadplata =", sum(nadplata_PLN, na.rm=TRUE), "PLN\n")


# Create list of input files from files in the directory that end in "depth.txt"
x_files <- list.files(pattern="*depth.txt")
# Create list of sample names from by reading the substring of characters [3:len-10) of each file name
sample_names <- substr(x_files, 3, nchar(x_files)-10)

# Define limits of plot, max_coverage evaluated is x, plot axis limit is x+2
coverage_max_to_check <- 70
plot_max <- coverage_max_to_check + 2

# Initialize output lists:
# 1 = list of lists of coverage depth from ranging 1-50,
# 2 = list of lists of quotients=(each value in list 1) divided by (sum of the values in list 1)
# 3 = list of mean coverage values and the mean value of the file(?)
output1 <- list()
output2 <- list()
mean_coverage <- c()
# For each file in the x_files list:
for(a in 1:length(x_files)) {
	## Make a list of all data values in the file (DATA_VALUES)
	a_rep <- scan(x_files[a])
	## Initialize local output list (OUTPUT_VALUES)
	a_output <- c()
	## For each coverage value within range of 1 to plot_max:
	for(b in 1:plot_max) {
		### If the value is equal to the plot_max:
		if(b == plot_max) {
			#### Append to local output list the count of all data values >= (plot_max - 1)
			a_output <- c(a_output, length(a_rep[a_rep >= (b - 1)]))
		} else {
			#### Else append to local output list the count of all data values == coverage value
			a_output <- c(a_output, length(a_rep[a_rep == (b - 1)]))
		}
	}
	## Local output #2 is each(?) output #1 value divided by the sum of all values in output #1
	a_output2 <- a_output / sum(a_output)
	## Append local output #1 to output list #1
	output1[[a]] <- a_output
	## Append local output #2 to output list #2
	output2[[a]] <- a_output2
	## Append mean coverage list with the mean of the current file
	mean_coverage <- c(mean_coverage, mean(a_rep))
}

# Remove the last file's list of data values from memory
rm(a_rep)
# Save work (lists) as RData file
save.image("myotis_coverage.RData")

# Make distribution plot of mean coverage vs proportion of genome

# Load work from RData file
load("myotis_coverage.RData")

# Initialize pdf for output plots
pdf("Myotis_coverage_plots.pdf")

# Plot the distribution of coverage vs proportion of ref genome for each individual/sample
par(mfrow=c(3,4))
for(a in 1:length(output2)) {
	plot(0:71, output2[[a]], pch=19, cex=0.1, xlab="Coverage", ylab="Proportion M. lucifugus genome", main=sample_names[a], ylim=c(0,0.10))
	poly.plot <- rbind(cbind(0:71, output2[[a]]), c(71, 0), c(0,0))
	polygon(poly.plot, col="gray")
	abline(v=mean_coverage[a], col="red")
}
dev.off()


library(matlib)
library(MASS)
library(extRemes)
library(class)
library(R.matlab)
library(RColorBrewer)
library(maps)

compute.variance.covariance<-function(scale,shape,lambda,m){
    temp<-matrix(c(2*scale^2,scale,scale,1+shape),2,2)
    N<-lambda*m
    frac<-(1+shape)/N
    return(frac*temp)}

simulate.bivariate<-function(n,scale,shape,lambda,m){
    mu<-c(scale,shape)
    Sigma<-compute.variance.covariance(scale,shape,lambda,m)
    if(det(Sigma)>0)
    return(mvrnorm(n,mu,Sigma))
    else return(matrix(NA,n,length(mu)))
}
RL.N<-function(N,shape,scale,thresh,lambda){thresh+(scale/shape)*((N*lambda)^shape-1)}   #derive return levels based on GP parameters
RP<-function(Z,shape,scale,thresh,lambda){
    rps<-ifelse(Z<=thresh,1,(1/(lambda))*(((shape/scale)*(Z-thresh)+1)^(1/shape)))
    rps[is.na(rps)]<-1000
    rps[rps<1]<-1
    rps[rps>1000]<-1000
    rps}

find.thresh<-function(Z,shape,scale,lambda,RP=100){
    thresh=Z-(scale/shape)*((lambda*RP)^shape-1)
    return(thresh)
}

unfold.quantiles<-function(qvalues,qs=c(1,5,16.7,50,83.3,95,99,99.5,99.9),n=1000){

    if(any(qs>1))qs<-qs/100
    samplesizes<-diff(qs)*n

    qsample<-numeric(0)
    for(ss in seq(length(samplesizes))){
        a<-qvalues[ss]
        b<-qvalues[ss+1]
        qsample<-c(qsample,runif(samplesizes[ss],a,b))
    }
    return(qsample)
}

g.coord<-function(x,y){
    pp<-par("usr")
    xr<-pp[2]-pp[1]
    yr<-pp[4]-pp[3]
    xpos<-x*xr+pp[1]
    ypos<-y*yr+pp[3]
    return(list(x=xpos,y=ypos))
}

"%&%"<-function(x,y)paste0(x,y)

find.match<-function(match1,match2,k=1,thresh=1){ #match2 is the larger set
    indy<-as.numeric(knn(train=cbind(match2$longitude,match2$latitude),test=cbind(match1$longitude,match1$latitude),cl=seq(nrow(match2)),k=k))#the order to apply to match1 to match match2
    distances<-numeric(0)
    for(i in 1:nrow(match1))distances[i]<-sqrt((match1$longitude[i]-match2$longitude[indy][i])^2+(match1$latitude[i]-match2$latitude[indy][i])^2)
    indyclean<-indy[distances<=1]
    rowclean<-seq(nrow(match1))[distances<=1]
    temp<-cbind(rowclean,indyclean)
    dimnames(temp)<-list(NULL,c("match1","match2"))
    return(temp)}

taper<-function(x,q1=0.05,q2=0.95){
    qx<-quantile(x,prob=c(q1,q2),na.rm=TRUE)
    x[x<qx[1]]<-qx[1]
    x[x>qx[2]]<-qx[2]
    return(x)}

get.early<-function(x,y){
    ux<-unique(x)
    uy<-numeric(length(ux))
    for(i in seq(length(uy))){
        uy[i]<-min(y[x==ux[i]])
    }
    return(uy)
}

transparent_col <- function(color, percent = 50, name = NULL) {
    #      color = color name
    #    percent = % transparency
    #       name = an optional name for the color

    ## Get RGB values for named color
    rgb.val <- col2rgb(color)

    ## Make new color using input color as base and alpha set by transparency
    t.col <- rgb(rgb.val[1], rgb.val[2], rgb.val[3],
                 max = 255,
                 alpha = (100 - percent) * 255 / 100,
                 names = name)

    ## Save the color
    invisible(t.col)
}

rasmussenScenarios<-c("1p5degree","2p0degree","2p0degree+L","2p5degree","3p0degree","4p0degree","5p0degree","5p0degree_rcp85+H")


suppressMessages(library(Matrix))
suppressMessages(library(cop))
comm.set.seed(1234, diff=TRUE)

n = 1000
prop_dense = .001

gen_sparse = function(m, n, prop_dense=0.001)
{
  n = as.integer(n)
  s = new("dgCMatrix", Dim=c(n, n), p=rep(0L, n+1))

  num_dense = as.integer(n*n*prop_dense)
  nzrows = sort(sample(n*n, size=num_dense, replace=FALSE))
  s[nzrows] = 1

  s
}

s = gen_sparse(n, n, prop_dense=prop_dense)
t = comm.timer({
  ret <- spadd_allreduce(s)
})

mpi_cat(sprintf("input density: %.2f%%\n", 100*prop_dense), quiet=TRUE)
mpi_cat(sprintf("outpt density: %.2f%%\n", 100*nnzero(ret)/prod(dim(s))), quiet=TRUE)
mpi_cat(sprintf("run time: %.3f\n", t[["max"]]), quiet=TRUE)

finalize()


resid.image<-function(dev.contrib,pred,raw.dat,x,y,model.type,file.name,out){
   z<-sign(pred-raw.dat)*dev.contrib
              a<-loess(z~x*y)
               x.lim<-rep(seq(from=min(out$dat$ma$train.xy[,1]),to=max(out$dat$ma$train.xy[,1]),length=100),each=100)
               y.lim<-rep(seq(from=min(out$dat$ma$train.xy[,2]),to=max(out$dat$ma$train.xy[,2]),length=100),times=100)
              z<-predict(a,newdata=cbind("x"=x.lim,"y"=y.lim))
              x.lim<-seq(from=min(out$dat$ma$train.xy[,1]),to=max(out$dat$ma$train.xy[,1]),length=100)
              y.lim<-seq(from=min(out$dat$ma$train.xy[,2]),to=max(out$dat$ma$train.xy[,2]),length=100)
                 z<-matrix(data=z,ncol=100,nrow=100,byrow=TRUE)
                # browser()
                 ########################################### experiment
                # if(out$input$make.binary.tif==TRUE | out$input$make.p.tif==TRUE){
                # out$dat$tif.ind[1]
                # RasterInfo=raster(out$dat$tif.ind[1])
                #  gi <- GDALinfo(out$dat$tif.ind[1])
                #    dims <- as.vector(gi)[1:2]
                #    ps <- as.vector(gi)[6:7]
                #    ll <- as.vector(gi)[4:5]
                 #   pref<-attr(gi,"projection")

                 # }

                 ##########################################################
              jpeg(file=paste(file.name,"resid.plot.jpg",sep="/"))
                 par(oma=c(3,3,3,3))
                 layout(matrix(data=c(1,2), nrow=1, ncol=2), widths=c(4,1), heights=c(1,1))
                  image(z,x=x.lim,y=y.lim,col=beachcolours(heightrange=c(min(z),max(z)),sealevel=0,ncolours=length(table(z))),
                  main="Spatial pattern of deviance residuals\n(magnitude and sign)",xlab="X coordinate",ylab="Y coordinate")
                  points(x,y,cex=.5)
                  #image(x=c(1,2),y=sort(unique(z)),z=matrix(data=cbind(rep(sort(unique(z)),times=2)),ncol=2),col=beachcolours(heightrange=c(min(z),max(z)),sealevel=0,ncolours=length(table(z))))
                  par(mar = c(3,2.5,2.5,2))
              colrange<-seq(from=min(z),to=max(z),length=100)
               image(1,colrange,
               matrix(data=colrange, ncol=length(colrange),nrow=1),
              col=beachcolours(heightrange=c(min(z),max(z)),sealevel=0,ncolours=length(colrange)),
              xlab="",ylab="",
              xaxt="n")
              graphics.off()
              return(a)
              }


#' Global Distance Metric Learning
#'
#' Performs Global Distance Metric Learning (GDM) on the given data, learning a diagonal matrix.
#'
#' Put GdmDiag function details here.
#'
#' @param data \code{n * d} data matrix. \code{n} is the number of data points,
#'             \code{d} is the dimension of the data.
#'             Each data point is a row in the matrix.
#' @param simi \code{n * 2} matrix describing the similar constrains.
#'              Each row of matrix is serial number of a similar pair in the original data.
#'				For example, pair(1, 3) represents the first observation is similar the 3th observation in the original data.
#' @param dism \code{n * 2} matrix describing the dissimilar constrains as \code{simi}.
#'				Each row of matrix is serial number of a dissimilar pair in the original data.
#' @param C0 numeric, the bound of similar constrains.
#' @param threshold numeric, the threshold of stoping the learning iteration.
#'
#' @return list of the GdmDiag results:
#' \item{newData}{GdmDiag transformed data}
#' \item{diagonalA}{suggested Mahalanobis matrix}
#' \item{dmlA}{matrix to transform data, square root of diagonalA }
#' \item{error}{the precision of obtained distance metric by Newton-Raphson optimization }
#'
#' For every two original data points (x1, x2) in newData (y1, y2):
#'
#' \eqn{(x2 - x1)' * A * (x2 - x1) = || (x2 - x1) * B ||^2 = || y2 - y1 ||^2}
#'
#' @keywords GDM global distance metirc learning transformation mahalanobis metric
#'
#' @note Be sure to check whether the dimension of original data and constrains' format are valid for the function.
#'
#' @author Gao Tao <\url{http://www.gaotao.name}>
#'
#' @export GdmDiag
#' @import MASS
#'
#' @references
#' Steven C.H. Hoi, W. Liu, M.R. Lyu and W.Y. Ma (2003).
#' Distance metric learning, with application to clustering with side-information.
#  in \emph{Proc. NIPS}.
#'

#' @examples
#' \dontrun{
#' set.seed(602)
#' library(MASS)
#' library(scatterplot3d)
#'
#' # generate simulated Gaussian data
#' k = 100
#' m <- matrix(c(1, 0.5, 1, 0.5, 2, -1, 1, -1, 3), nrow =3, byrow = T)
#' x1 <- mvrnorm(k, mu = c(1, 1, 1), Sigma = m)
#' x2 <- mvrnorm(k, mu = c(-1, 0, 0), Sigma = m)
#' data <- rbind(x1, x2)
#'
#' # define similar constrains
#' simi <- rbind(t(combn(1:k, 2)), t(combn((k+1):(2*k), 2)))
#'
#' temp <-  as.data.frame(t(simi))
#' tol <- as.data.frame(combn(1:(2*k), 2))
#'
#' # define disimilar constrains
#' dism <- t(as.matrix(tol[!tol %in% simi]))
#'
#' # transform data using GdmDiag
#' result <- GdmDiag(data, simi, dism)
#' newData <- result$newData
#' # plot original data
#' color <- gl(2, k, labels = c("red", "blue"))
#' par(mfrow = c(2, 1), mar = rep(0, 4) + 0.1)
#' scatterplot3d(data, color = color, cex.symbols = 0.6,
#'			  xlim = range(data[, 1], newData[, 1]),
#'			  ylim = range(data[, 2], newData[, 2]),
#'			  zlim = range(data[, 3], newData[, 3]),
#'			  main = "Original Data")
#' # plot GdmDiag transformed data
#' scatterplot3d(newData, color = color, cex.symbols = 0.6,
#'			  xlim = range(data[, 1], newData[, 1]),
#'			  ylim = range(data[, 2], newData[, 2]),
#'			  zlim = range(data[, 3], newData[, 3]),
#'			  main = "Transformed Data")
#' }
#'
GdmDiag <- function(data, simi, dism, C0 = 1, threshold = 0.001) {
		fudge = 0.000001
		reduction = 2
		data <- as.matrix(data)
		simi <- as.matrix(simi)
		dism <- as.matrix(dism)
		N <- dim(data)[1]
		d <- dim(data)[2]
		a <- matrix(rep(1, d), nrow = d)# initial diagonal A in the form of column vector
		# dij <- mat.or.vec(1, d)

		new.simi <- unique(t(apply(simi, 1, sort)))
		new.dism <- unique(t(apply(dism, 1, sort)))

		######### contraints
		dist1.dism <- data[new.dism[, 1], ] - data[new.dism[, 2], ]
		dist.ij <- sqrt((dist1.dism^2) %*% a)
		sum.dist <- sum(dist.ij)
		temp <- cbind(dist1.dism^2, dist.ij)
		deri1.ij <-0.5 * temp[, 1:d]/(temp[, d + 1] + (temp[, d + 1] == 0) * fudge)
		sum.deri1 <- t(apply(deri1.ij, 2, sum))
		deri2.ij <- t(apply(dist1.dism, 1, function(x) outer(x, x)))
		temp1 <- cbind(deri2.ij, dist.ij^3)
		deri2.ij <- -0.25 * temp1[, 1:(d^2)]/(temp1[, d^2 + 1] + (temp1[, d^2 + 1] == 0) * fudge)
		sum.deri2 <- matrix(apply(deri2.ij, 2, sum), ncol = d, byrow = TRUE)

		fD <- log(sum.dist)
		fD.1d <- sum.deri1/sum.dist
		fD.2d <- sum.deri2/sum.dist - crossprod(sum.deri1, sum.deri1)/(sum.dist^2)

		####### objection is part of contraints
		# fD <- log(sum.dist)
		######################################
		dist1.dism <- data[new.dism[, 1], ] - data[new.dism[, 2], ]
		d.sum <- t(apply(dist1.dism^2, 2, sum))
		dist1.simi <- data[new.simi[, 1], ] - data[new.simi[, 2], ]
		s.sum <- t(apply(dist1.simi^2, 2, sum))

		# S1 <- mat.or.vec(N, N)
		# D1 <- mat.or.vec(N, N)

		# dism <- rbind(dism, dism[, c(2, 1)]) #
		# Dism <- rbind(Dism, Dism[, c(2, 1)])
		# S1[dism] <- 1
		# D1[Dism] <- 1

		error <- 1
		while (error > threshold) {
			obj.initial <- as.numeric(s.sum %*% a) + C0 * fD
			fS.1d <- s.sum

			gradient <- fS.1d - C0 * fD.1d
			hessian <- -C0 * fD.2d + fudge * diag(1, d)
			invhessian <- solve(hessian)
			cstep <- invhessian %*% t(gradient)

			lambda <- 1
			atemp <- a - lambda * cstep
			atemp[atemp < 0] <- 0

			fDo <- log(sum(sqrt((dist1.dism^2) %*% atemp)))
			obj <- as.numeric(s.sum %*% atemp) + C0 * fDo
			obj.previous <- obj * 1.1

			while (obj < obj.previous) {
				lambda.previous <- lambda
				obj.previous <- obj
				a.previous = atemp
				lambda <- lambda/reduction
				atemp <- a - lambda * cstep
				atemp[atemp < 0] <- 0
				fDo1 <- log(sum(sqrt((dist1.dism^2) %*% atemp)))
				obj <- as.numeric(s.sum %*% atemp) + C0 * fDo1
			}
		a <- a.previous
		error <- abs((obj.previous - obj.initial)/obj.previous)
		}
		diagonalA <- diag(as.numeric(a))
		dmlA <- sqrt(diagonalA)
		newData <- data %*% dmlA

		return(list("newData" = newData, "diagonalA" = diagonalA, "dmlA" = dmlA, "error" = error))
}


install.packages(c('ISLR', 'e1071'))

library(e1071)
library(ISLR)

    cleveland <- read.csv("~/datasets/processed.cleveland.csv",header=T)
    hungarian <- read.csv("~/datasets/processed.hungarian.csv",header=T)
    va <- read.csv("~/datasets/processed.va.csv",header=T)
    switzerland<- read.csv("~/datasets/processed.switzerland.csv",header=T)

    data<-rbind(cleveland,hungarian,va,switzerland)
    data$slope<-NULL
    data$ca<-NULL
    data$thal<-NULL
    data$class<-as.numeric(data$class)
    data$class[(data$class>1)]<-"1"

    #find ? elements
     idx<-data =="?"
     #replace elements with NA
     is.na(data) <- idx

     for(i in 1:ncol(data)){ #for every column of our data
     data[is.na(data[,i]), i] <- mean(as.numeric(data[,i]), na.rm =TRUE)
     #replace every missing values with the mean of that column
     }

      data[] <- lapply(data, as.factor)

      library(e1071)
      #split dataset
      set.seed(3233)
      train =sample(nrow(data), nrow(data)*2/3)
      test=-train
      data_test=data[test,]
      data_train=data[train,]
      #generit Matrix table
      svm.data <- svm(data_train$class ~., data_train, kernel ="linear", cost=.1,
                      preprocess=c("center","scale"), metric="ROC",scale=FALSE)
      prediction <- predict(svm.data, data_test, type = 'class')
      summary(svm.data)

      m<- table(prediction, data_test$class)
      print(m)
      n=sum(m)
      nc=nrow(m)

      diag=diag(m)
      rowsums=apply(m,1,sum)
      colsums=apply(m,2,sum)
      p=rowsums
      q=colsums

       accuracy=sum(diag)/n
       accuracy
       accuracyaverage = mean(accuracy)
       accuracyaverage

       precision=diag/colsums
       precision

       recall=diag/rowsums
       recall

       recall
       recallaverage = mean(recall)
       recallaverage
       plot(data$class,data$age, col=c(28,32))

#    # Create model and save in a separate file
# svm_model<- svm(class ~., data = data)
# svm_model
#
# save(svm.r, file="svm.r")


# Pull PWT into dataframe
data("pwt9.1")

p <- pwt9.1 # copy dataframe for manipulation
p$lngdppc <- round(log(p$rgdpna) - log(p$pop),digits=2) # create log GDP per capita
p$emppop <- round(p$emp/p$pop,digits=2) # employee/pop ratio

catchup <- p[ which(p$isocode %in% c("USA", "DEU", "JPN", "KOR", "CHN","NGA")),]

fig <- plot_ly(catchup, x = ~year, y = ~emppop, linetype = ~country, type = 'scatter', mode = 'lines+markers')
fig <- layout(fig, title = list(text = 'Employee/Pop ratio by country', x=0),
              xaxis = list(title = 'Year'),
              yaxis = list (title = 'Employee/pop ratio',range=c(0.2,0.8)),
              hovermode="x unified")
api_create(fig, filename = "pwt-catchup-emppop")

p <- read.csv("~/Dropbox/project/studyguide/data/pwt91_labor_detail.csv", header=TRUE)
catchup <- p[ which(p$countrycode %in% c("USA", "DEU", "JPN", "KOR", "CHN","NGA")),]

fig <- plot_ly(catchup, x = ~year, y = ~yr_sch, linetype = ~countrycode, type = 'scatter', mode = 'lines+markers')
fig <- layout(fig, title = list(text = 'Years of schooling by country', x=0),
              xaxis = list(title = 'Year'),
              yaxis = list (title = 'Avg. years of schooling',range=c(0,15)),
              hovermode="x unified")
api_create(fig, filename = "pwt-catchup-yrsch")


#' Convert a variable to a format that can be included in a design matrix.
#' Characters and unordered factors are converted to model matrices with binary dummy variables.
#' Ordered factors are converted to integers corresponding to ordered levels.
#' Other variables are left asis.
simplify.variable <- function(v) {
    if (is.character(v))
        v <- as.factor(v)
    if (is.factor(v)) {
        v <- droplevels(v)
        if (is.ordered(v) || length(levels(v)) <= 2)
            as.integer(v) - 1
        else
            model.matrix(~ v, model.frame(~ v, na.action=na.pass))[,-1,drop=F]
    } else
        v
}


library(Romp)
library(rbenchmark)

cols <- c("test", "replications", "elapsed", "relative")

x <- rnorm(2.5e7)
benchmark(sum(x), c_sum(x), rcpp_sum(x), f77_sum(x), f90_sum(x), columns=cols, order="relative")


library(datasets)

head(iris)

#item a
plot(iris$Sepal.Length, iris$Sepal.Width, pch=19, col = "#cc0000", xlab="Comprimento da pétala", ylab="Largura da pétala")

#item b
x = iris$Petal.Length
print(length(x[x >= 2 & x <= 5]))

#item c
print(unique(iris$Species))

#item d
print(mean(iris$Sepal.Width))


  form.bins = function(base=2, x0, x1, length.out, log.transf=T) {

    if (log.transf) {
      lbound = log( x0, base=base )
      ubound = log( x1, base=base )
      i = seq(lbound, ubound, length.out=length.out+1)
      x = base^i
      nbins = length( x ) - 1
      lb = x[1: nbins]
      ub = x[2: (nbins+1)]
      mids = ( lb + ub )/2
      out = data.frame( mids=mids, lb=lb, ub=ub )
      out = log(out, base=base)

    } else {
      lbound = x0
      ubound = x1
      x = seq(lbound, ubound, length.out=length.out+1)
      nbins = length( x ) - 1
      lb = x[1: nbins]
      ub = x[2: (nbins+1)]
      mids = ( lb + ub )/2
      out = data.frame( mids=mids, lb=lb, ub=ub )
    }

    return(out)
  }


# ---------> complete and run the following code for this assignment <-------
##
R code for STA457 assignment 1
# copyright by Christina (Qi) Deng
# date: Jan 21, 2017
#
## Q1:
# load in data
dollar <- scan ("/Users/christinadeng/Desktop/Winter 2017/STA 457/Assignment 1/dollar.txt")
# get the time series of log(dollar)
dollar <- ts(log(dollar))
# define the first difference
returns <- diff(dollar)
# (a) Plot the correlogram and periodogram of the orginal data (i.e. dollar)
acf(dollar,lag.max=20)
spec.pgram(dollar,demean=T,detrend=F)
# (b) Plot the correlogram and periodogram of the first differences.
acf(returns, lag.max=20)
spec.pgram(returns,demean=T,detrend=F) # max not at 0
# (c) Analysis
# (d) Plot the correlogram and periodogram of the absolute values of the first difference
acf(abs(returns), lag.max=20)
spec.pgram(abs(returns),demean=T,detrend=F) # max at 0
# Q2:
# load in data
CO2 <- scan("/Users/christinadeng/Desktop/Winter 2017/STA 457/Assignment 1/CO2.txt")
CO2trend <- scan("/Users/christinadeng/Desktop/Winter 2017/STA 457/Assignment 1/CO2-trend.txt")
# (a) Plot the periodogram of the time series.
spec.pgram((CO2),demean=T,detrend=F)
# (b)Plot periodogram of the detrended data.
detrended=CO2-CO2trend
spec.pgram((detrended), demean=T,detrend=F)

# ---------> complete and run the following code for this assignment <-------
##
R code for STA457 assignment 2
# copyright by Christina (Qi) Deng
# date: Feb 14, 2017
#
# Q2:
# load in data
flour <- scan ("/Users/christinadeng/Desktop/Winter 2017/STA 457/ Assignment 2/flour.txt")
# get the time series of flour data
flour <- ts(flour)
# (a) get time series plot of the data
par(mfrow=c(1,2))
plot(flour,main="Monthly values of the Kansas City flour price index",xlab="month")
log_flour <- ts(log(flour))
plot(log_flour,main="Monthly values of the Kansas City Log flour price index",xlab="month")
# (b) Plot the correlogram, partial correlogram and periodogram of the data.
acf(flour,lag.max=20)
pacf(flour, lag.max=20)
spec.pgram(flour,demean=T,detrend=F)
# (c) Which of the following models seems to be most appropriate for these data: an autore-gressive model, a moving install.packages("forecast")
library(forecast)
auto.arima(flour)
# get MA(1), AR(1), AND Random Walk Model
MA1 <- arima(flour,c(0,0,1))
AR1 <- arima (flour, c(1,0,0))
RW <- arima(flour,c(0,1,0))
# generate AIC output
MA1$aic
AR1$aic
RW$aic
# do Box.test to check their p-value
Box.test(MA1$residuals)
Box.test(AR1$residuals)
Box.test(RW$residuals)

# ---------> complete and run the following code for this assignment <-------
##
R code for STA457 assignment 3
# copyright by Christina (Qi) Deng
# date: March 14, 2017
#
#1(a)
library(tseries)
dollar <- scan ("/Users/christinadeng/Desktop/Winter 2017/STA 457/Assignment 1/dollar.txt")
dollar <- ts(log(dollar))
adf.test(dollar,k=5)
adf.test(dollar,k=10)
adf.test(dollar,k=15)
#(b)
dollar_d = diff(dollar)
bartlett <- function(x,plot=F) {
x <- as.vector(x)
x <- x - mean(x)
n <- length(x)
m <- floor(n/2)+1
s <- Mod(fft(x)[1:m])^2/n
sums <- sum(s)
cumper <- cumsum(s)/sums
v <- c(0:(m-1))/(m-1)
upper <- v + 2*sqrt(v*(1-v))/sqrt(n/2)
lower <- v - 2*sqrt(v*(1-v))/sqrt(n/2)
a <- max(abs(cumper-v))*sqrt(n/2)
sgn <- 1
j <- 1
incr <- 2*exp(-2*a^2)
pval <- incr
while ( incr > 1e-5 ) {
sgn <- -sgn
j <- j + 1
incr <- 2*exp(-2*a^2*j^2)
pval <- pval + sgn*incr
}
tit <- paste("Bartlett's statistic=",round(a,3),"p-value=",round(pval,4))
if (plot) {
plot(v,cumper,xlab=" ",ylab="Cumulative periodogram",pch=20)
abline(0,1)
lines(v,upper,lty=2)
lines(v,lower,lty=2)
title(sub=tit)
}
bartlett <- a
pvalue <- pval
r <- list(stat=bartlett,p.value=pvalue)
r
}
bartlett(dollar_d)
Box.test(dollar_d, lag=5,type="Ljung")
Box.test(dollar_d, lag=10, type="Ljung")
Box.test(dollar_d, lag=15, type="Ljung")
#2(a)
yield = scan("/Users/christinadeng/Desktop/Winter 2017/STA 457/Assignment 3/yield.txt")
yield_d = diff(ts(yield))
adf.test(yield, k=5)
adf.test(yield, k=10)
adf.test(yield, k=15)
bartlett(yield_d)
Box.test(yield_d, lag=10, type="Ljung")
#(b)
arima1=arima(yield, order=c(1,1,1))
arima2=arima(yield, order=c(2,1,2))
arima3=arima(yield, order=c(3,1,3))
arima1$aic
arima2$aic
arima3$aic
#(d)
tsdiag(arima3)
qqnorm(arima3$residuals)
qqline(arima3$residuals,col="purple", pch=21)
#3(a)
fatalities <- scan("/Users/christinadeng/Desktop/Winter 2017/STA 457/Assignment 3/fatalities.txt")
fatalities <- ts(log(fatalities))
fata_d <- diff(diff(fatalities),12)
par(mfrow=c(1,2))
acf(fata_d)
pacf(fata_d)
f1=arima(fatalities,order=c(0,1,1), seasonal=list(order=c(0,1,1),period=12))
bartlett(f1$residuals)
#(b)
P_f1 <- predict(f1,n.ahead=12)
plot(exp(P_f1$pred),ylim=c(45, 325), ylab="number of traffic fatalities", main="Forcast the number of traffic lines(exp(P_f1$pred + 1.96*P_f1$se),lty=2)
lines(exp(P_f1$pred - 1.96*P_f1$se),lty=2)
#(c)
fatalities2 <- fatalities[1:168]
f2=arima(fatalities2,order=c(0,1,1), seasonal=list(order=c(0,1,1),period=12))
P_f2 <- predict(f2,n.ahead=12)
plot(exp(P_f2$pred),ylim=c(45, 325), ylab="number of traffic fatalities", main="Forcast the number of traffic lines(exp(P_f2$pred + 1.96*P_f2$se),lty=2)
lines(exp(P_f2$pred - 1.96*P_f2$se),lty=2)
points(c(169:180),exp(fatalities[169:180]))

# ---------> complete and run the following code for this assignment <-------
##
R code for STA457 assignment 4
# copyright by Christina (Qi) Deng
# date: March 27, 2017
#
#1(a)
fatal <- scan("/Users/christinadeng/Desktop/Winter 2017/STA 457/Assignment 4/fatalities.txt")
fatal <- ts(fatal,start=c(1960,1),end=c(1974,12),freq=12)
r <- stl(fatal,s.window = "periodic", robust = T, t.window = 41)
plot(r, main="stl with s='periodic' & t=41")
r <- stl(fatal,s.window = 3, robust = T, t.window = 51)
plot(r, main="stl with s=3 & t=51")
r <- stl(fatal,s.window = 5, robust = T, t.window = 61)
plot(r,main="stl with s=5 & t=61")
r <- stl(fatal,s.window = 7, robust = T, t.window = 71)
plot(r,main="stl with s=7 & t=71")
#(b)
remainder1=stl(fatal,s.window = 7,t.window = 71)$time.series[,"remainder"]
acf(remainder1)
pacf(remainder1)
remainder2=stl(fatal,s.window = 3,t.window = 41)$time.series[,"remainder"]
acf(remainder2)
pacf(remainder2)
#2(a)
spec.parzen <- function(x,maxlag,nfreq,plot=T) {
f <- 1
if (is.ts(x)) f <- frequency(x)
x <- as.vector(x[!is.na(x)])
n <- length(x)
x <- x - mean(x)
if (missing(maxlag)) maxlag <- n - 1
if (maxlag >= n) maxlag <- n - 1
if (maxlag <= 1) maxlag <- 2
k <- ceiling(log(n+maxlag)/log(2))
nn <- 2^k
m <- nn/2
if (missing(nfreq)) nfreq <- m
if (nfreq < m) nfreq <- m
if (nfreq > m) {
k <- 1 + ceiling(log(nfreq)/log(2))
nn <- 2^k
nfreq <- nn/2
}
x <- c(x,rep(0,nn-n))
if (missing(maxlag)) maxlag <- n - 1
if (maxlag >= n) maxlag <- n - 1
if (maxlag <= 1) maxlag <- 2
k1 <- floor(maxlag/2)
k2 <- maxlag
k <- c(0:k1)
window <- 1 - 6*(k/maxlag)^2 + 6*(k/maxlag)^3
k <- c((k1+1):k2)
window <- c(window,2*(1-k/maxlag)^3)
if (maxlag < nn) window <- c(window,rep(0,nn-maxlag-1))
spec <- Mod(fft(x))^2/n
ac <- Re(fft(spec,inv=T))/nn
ac <- ac*window
spec <- 2*Re(fft(ac))-ac[1]
spec <- 10*log10(spec[1:(nfreq+1)])
freq <- f*c(0:nfreq)/nn
se <- 4.342945*sqrt(0.539*maxlag/n)
if (plot) {
lims <- c(min(spec - 1.96*se),max(spec + 1.96*se))
plot(freq,spec,type="l",xlab="frequency",ylab="spectrum",ylim=lims)
lines(freq,spec + 1.96*se,lty=2)
lines(freq,spec - 1.96*se,lty=2)
ttl <- paste("Parzen's window with M=",maxlag)
title(sub=ttl)
}
std.err <- se
r <- list(frequency=freq,spec=spec,M=maxlag,std.err=std.err)
r}
speech <- ts(scan("/Users/christinadeng/Desktop/Winter 2017/STA 457/Assignment 4/speech.txt"),frequency=r <- spec.parzen(speech,maxlag=10,plot=T)
r <- spec.parzen(speech,maxlag=30,plot=T)
r <- spec.parzen(speech,maxlag=60,plot=T)
r <- spec.parzen(speech,maxlag=90,plot=T)
r <- spec.parzen(speech,maxlag=100,plot=T)
#(b)
r <- spec.ar(speech,order=10,method="burg")
r <- spec.ar(speech,order=20,method="burg")
r <- spec.ar(speech,order=30,method="burg")
r <- spec.ar(speech,method="yw")
#3(a)
library(tseries)
barrick <- scan("/Users/christinadeng/Desktop/Winter 2017/STA 457/Assignment 4/barrick.txt")
adf.test(ts(barrick))
m1<-arima(barrick,c(0,1,1))
m1$aic
m2<-arima(barrick,c(0,1,2))
m2$aic
Box.test(m1$residuals,type="Ljung", lag=10)
Box.test(m2$residuals,type="Ljung", lag=10)
#(b)
library('fGarch')
R=m2$residuals
F1=garchFit(R~garch(1,0),data=R,trace=F)
summary(F1)
F2=garchFit(R~garch(2,0),data=R,trace=F)
summary(F2)
F3=garchFit(R~garch(3,0),data=R,trace=F)
summary(F3)
F4=garchFit(R~garch(4,0),data=R,trace=F)
summary(F4)
F5=garchFit(R~garch(5,0),data=R,trace=F)
summary(F5)
#(c)
f1=garchFit(R~garch(1,1),data=R,trace=F)
summary(f1)
f2=garchFit(R~garch(1,2),data=R,trace=F)
summary(f2)
f3=garchFit(R~garch(1,3),data=R,trace=F)
summary(f3)
f4=garchFit(R~garch(1,4),data=R,trace=F)
summary(f4)
f5=garchFit(R~garch(1,5),data=R,trace=F)
summary(f5)


# rm(list = ls())
n = 1000
k = 10
p = 5
h1 = matrix(rnorm(n * k), ncol = k, nrow = n)
h2 = matrix(rnorm(n * k), ncol = k, nrow = n)
beta_f = matrix(rnorm(k * p), ncol = p, nrow = k)
beta_m = matrix(rnorm(k * p), ncol = p, nrow = k)
yf = h1 %*% beta_f + matrix(rnorm(n * p), ncol = p, nrow = n) * 10
ym = h2 %*% beta_m + matrix(rnorm(n * p), ncol = p, nrow = n) * 10
# #
# library(reticulate)
# np <- import("numpy")
# h1 = np$load('notebook/h1.npy')
# h2 = np$load('notebook/h2.npy')
# yf = np$load('notebook/yf.npy')
# ym = np$load('notebook/ym.npy')

source('code/rlib_em_per_snp.R')
o = em_per_snp(yf, ym, h1[, 1:5], h2[, 1:5])
o$inter
o$beta
o$lld
o$sigma2

hist(o$prob_z)

# o$lld[20:68] + 972676

l1f = NULL
l0f = 0
l1m = NULL
l0m = 0
for(i in 1 : p) {
  yfp1 = .mat_vec_by_row(.mat_vec_by_row(h1, o$beta$f[, i], '*'), o$inter$f[, i], '+')
  yfp2 = h2 * o$beta$f[, i] + o$inter$f[, i]
  ymp1 = .mat_vec_by_row(.mat_vec_by_row(h2, o$beta$m[, i], '*'), o$inter$m[, i], '+')
  ymp2 = h1 * o$beta$m[, i] + o$inter$m[, i]
  rfp1 = .mat_vec_by_col(yfp1, yf[, i], '-'); rfp1_sq = .mat_vec_by_row(rfp1 ^ 2, o$sigma2$f[, i], '/')
  rfp2 = yf[, i] - yfp2; rfp2_sq = rfp2 ^ 2 / o$sigma2$f[, i]
  rmp1 = .mat_vec_by_col(ymp1, ym[, i], '-'); rmp1_sq = .mat_vec_by_row(rmp1 ^ 2, o$sigma2$m[, i], '/')
  rmp2 = ym[, i] - ymp2; rmp2_sq = rmp2 ^ 2 / o$sigma2$m[, i]
  l1f = cbind(l1f, rowSums(rfp1_sq)); l0f = l0f + rfp1_sq
  l1m = cbind(l1m, rowSums(rmp1_sq)); l0m = l0m + rmp2_sq
}
# sum(l1)
# sum(l0)

lf = get_l(yf, h1, h2, o$beta$f, o$inter$f, o$sigma2$f)
lm = get_l(ym, h2, h1, o$beta$m, o$inter$m, o$sigma2$m)
get_lld(lf, lm, 0.5, o$sigma2$f, o$sigma2$m)

l1 = rowSum(l1) + log(0.5)
l0 = rowSum(l0) + log(0.5)
.logsum(-sum(l1), -sum(l0)) - n * sum(log(o$sigma2$f) + log(o$sigma2$m))

plot(o$lld[2:30])

# y = yf[, 2]
# x = h1[, 2]
#
# mod = lm(y ~ x)
# logLik(mod)
#
# b = mod$coefficients
#
# yp = x * b[2] + b[1]
# s2 = summary(mod)$sigma^2
#
# -  sum((yp - y)^2) / 2 / s2 - 0.5 * length(x) * log(2 * pi * s2)

source('code/rlib_em_otf.R')
o2 = em_algorithm_otf(yf, ym, h1, h2)
# # o$prob_z
# plot(o$lld[5:20])
# hist(o$prob_z)
plot(o2$lld[2:20])
hist(o2$gamma)
hist(o$prob_z)
plot(o$prob_z, o2$gamma)
#
# source('code/rlib_em_per_snp.R')
# x1 = rnorm(n)
# x2 = rnorm(n)
# y1 = x1 + rnorm(n)
# y2 = x2 + rnorm(n)
# w = runif(n / 2)
#
# lm_wrap = function(y, x, w) {
#   mod = lm(y ~ x, weights = w)
#   beta = mod$coefficients
#   resid = y - cbind(rep(1, length(x)), x) %*% as.numeric(beta)
#   sigma2 = sum(resid ^ 2 * w) / sum(w)
#   list(beta = beta, sigma2 = sigma2)
# }
#
# b = update_beta_and_inter(cbind(x1, x2), cbind(y1, y2), w)
# update_sigma2(cbind(x1, x2), cbind(y1, y2), w, b$beta, b$inter)
# b
#
# lm_wrap(y1, x1, c(w, 1-w))
# lm_wrap(y2, x2, c(w, 1-w))
# lm_wrap(y2, x1, c(w, 1-w))


require(dplyr)
require(ggplot2)
require(reshape2)

source('crp.r')

design = expand.grid(epochs = 100, n = 1000, a = c(1, 10, 100))

simulate = function(epochs, n, a) replicate(epochs, list(crp(n, a)))

experiment = apply(
    design
  , MARGIN = 1
  , function(row) { simulate(row[1], row[2], row[3]) }
  )

results          = melt(experiment, id.vars = 'table')
by_concentration = group_by(results, table = table, settings = factor(L1))

log_log_plot =
  ggplot(by_concentration, aes(table, value, fill = settings, colour = settings)) +
  geom_jitter(width = 0.5, height = 0.45, alpha = 0.2) +
  scale_x_log10() + scale_y_log10()

summarised = summarise(by_concentration, customers = mean(value))

mean_log_log_plot =
  ggplot(summarised, aes(table, customers, fill = settings, colour = settings)) +
  geom_point(alpha = 0.8) +
  scale_x_log10() + scale_y_log10()


## Dale W.R. Rosenthal, 2018
## You are free to distribute and use this code so long as you attribute
## it to me or cite the text.
## The legal disclaimer in _A Quantitative Primer on Investments with R_
## applies to this code.  Use or distribution without these comment lines
## is forbidden.
library(xts)
library(Quandl)

# Read in spot fx rates
fxspot.tickers <- c("CURRFX/USDEUR", "CURRFX/USDJPY", "CURRFX/USDCHF")
fxspot.raw <- Quandl(fxspot.tickers[1], type="xts")
for (i in 2:length(fxspot.tickers)) {
  fxspot.temp <- Quandl(fxspot.tickers[i], type="xts")
  fxspot.raw <- merge(fxspot.raw, fxspot.temp)
}
colnames(fxspot.raw) <- c("USDEUR.spot", "USDJPY.spot", "USDCHF.spot")

# Read in future fx rates
fxfut.tickers <- c("CHRIS/CME_EC1", "CHRIS/CME_JY1", "CHRIS/CME_SF1")
fxfut.raw <- Quandl(fxfut.tickers[1], type="xts")
for (i in 2:length(fxfut.tickers)) {
  fxfut.temp <- Quandl(fxfut.tickers[i], type="xts")
  fxfut.raw <- merge(fxfut.raw, fxfut.temp)
}
colnames(fxfut.raw) <- c("USDEUR.fut", "USDJPY.fut", "USDCHF.fut")

# Read in 3M USD deposit futures
usd.3m.raw <- Quandl("CHRIS/CME_ED1", type="xts")[,"Settle"]
eur.3m.raw <- Quandl("CHRIS/LIFFE_I1", type="xts")[,"Settle"]
jpy.3m.raw <- Quandl("CHRIS/CME_EY1", type="xts")[,"Settle"]
chf.3m.raw <- Quandl("CHRIS/LIFFE_S1", type="xts")[,"Settle"]
chf.3m.raw["20150122"] <- 101.08  # Fix 1st data error
chf.3m.raw["20150508"] <- 100.83  # Fix 2nd data error
deposits3m.raw <- cbind(usd.3m.raw, eur.3m.raw, jpy.3m.raw, chf.3m.raw)
deposits3m <- (100-deposits3m.raw)/100  # convert futures prices to yield
colnames(deposits3m) <- c("3MUSDLIBOR", "3MCHFLIBOR", "3MJPYTIBOR", "3MEURIBOR")

alldata.full <- cbind(fxspot.raw, deposits3m, fxfut.raw)
alldata <- alldata.full["2013/"]

# here some calculations have to happen...


## 1. Exploring Academic Success and Demographics by Borough ##

combined <- read_csv("combined.csv")

## 2. Defining "Missing Data" ##

summary <- combined %>%
  group_by(boro) %>%
  summarize(mean(avg_sat_score))

## 3. Contagious Missing Values ##

summary <- combined %>%
  group_by(boro) %>%
  summarize(mean(avg_sat_score))
summary <- combined %>%
  group_by(boro) %>%
  summarize(mean(avg_sat_score, na.rm = TRUE))

## 4. Dropping Rows With Missing Values for one Variable ##

summary <- combined %>%
  group_by(boro) %>%
  summarize(mean(avg_sat_score, na.rm = TRUE))
summary_2 <- combined %>%
  drop_na(boro) %>%
  group_by(boro) %>%
  summarize(sat_avg = mean(avg_sat_score, na.rm = TRUE))

## 5. Complete Cases: Dropping All Rows With Missing Data ##

summary_3 <- combined %>%
  drop_na() %>%
  group_by(boro) %>%
  summarize(mean(avg_sat_score))

## 6. Using Complete Cases: When to Avoid ##

na_count <- colSums(is.na(combined))

## 7. Understanding Effects of Different Techniques for Handling Missing Data ##

summary_4 <- combined %>%
    drop_na(boro) %>%
    group_by(boro) %>%
    summarize(mean(avg_sat_score, na.rm = TRUE), mean(frl_percent, na.rm = TRUE), mean(`AP Test Takers`, na.rm = TRUE))

## 8. Imputing to Replace Missing Data ##

combined <- combined  %>%
  mutate(`AP Test Takers` = replace_na(`AP Test Takers`, 2.5))

combined_2 <- combined %>%
  drop_na(boro)

ggplot(data = combined_2) +
    aes(x = boro, y = `AP Test Takers`) +
    geom_boxplot()

Data Analyst in R/Step 3 - Data Cleaning in R/1. Data Cleaning in R/4. Dealing With Missing Data.r


#' Calculate the Jaccard statistic for two sets of intervals.
#'
#' Quantifies the extent of overlap between to sets of intervals in terms of
#' base-pairs. Groups that are shared between input are used to calculate the statistic
#' for subsets of data.
#'
#' @details The Jaccard statistic takes values of `[0,1]` and is measured as:
#'
#' \deqn{ J(x,y) = \frac{\mid x \bigcap y \mid}
#'                      {\mid x \bigcup y \mid} =
#'                 \frac{\mid x \bigcap y \mid}
#'                      {\mid x \mid + \mid y \mid -
#'                       \mid x \bigcap y \mid} }
#'
#' @param x [ivl_df]
#' @param y [ivl_df]
#'
#' @template stats
#'
#' @family interval statistics
#'
#' @return
#' tibble with the following columns:
#'
#'   - `len_i` length of the intersection in base-pairs
#'   - `len_u` length of the union in base-pairs
#'   - `jaccard` value of jaccard statistic
#'   - `n_int` number of intersecting intervals between `x` and `y`
#'
#' If inputs are grouped, the return value will contain one set of values per group.
#'
#' @seealso
#'   \url{http://bedtools.readthedocs.org/en/latest/content/tools/jaccard.html}
#'
#' @examples
#' genome <- read_genome(valr_example('hg19.chrom.sizes.gz'))
#'
#' x <- bed_random(genome, seed = 1010486)
#' y <- bed_random(genome, seed = 9203911)
#'
#' bed_jaccard(x, y)
#'
#' # calculate jaccard per chromosome
#' bed_jaccard(dplyr::group_by(x, chrom),
#'             dplyr::group_by(y, chrom))
#'
#' @export
bed_jaccard <- function(x, y) {
  x <- check_interval(x)
  y <- check_interval(y)

  groups_shared <- shared_groups(x, y)

  x <- bed_merge(x)
  y <- bed_merge(y)

  res_intersect <- bed_intersect(x, y)

  if (!is.null(groups_shared)) {
    x <- group_by(x, !!! syms(groups_shared))
    y <- group_by(y, !!! syms(groups_shared))

    res_intersect <- group_by(res_intersect, !!! syms(groups_shared))
  }

  res_intersect <- summarize(
    res_intersect,
    sum_overlap = sum(as.numeric(.overlap)),
    n_int = as.numeric(n())
  )

  res_x <- mutate(x, .size = end - start)
  res_x <- summarize(res_x, sum_x = sum(as.numeric(.size)))

  res_y <- mutate(y, .size = end - start)
  res_y <- summarize(res_y, sum_y = sum(as.numeric(.size)))

  if (!is.null(groups_shared)) {
    res <- left_join(res_intersect, res_x, by = as.character(groups_shared))
    res <- left_join(res, res_y, by = as.character(groups_shared))

    res <- mutate(res, sum_xy = sum_x + sum_y)
    group_cols <- select(res, !!! syms(groups_shared))

    res <- transmute(
      res,
      len_i = sum_overlap,
      len_u = sum_xy,
      jaccard = sum_overlap / (sum_xy - sum_overlap),
      n = n_int
    )

    res <- bind_cols(group_cols, res)
  } else {
    n_i <- res_intersect$sum_overlap
    n_u <- res_x$sum_x + res_y$sum_y

    jaccard <- n_i / (n_u - n_i)

    res <- tibble(
      len_i = n_i,
      len_u = n_u,
      jaccard = jaccard,
      n = res_intersect$n_int
    )
  }

  res
}


source("Core/sagpfuns.r")
source("Core/kernel.R")

########
# Data #
########

#Generate data to fit SAGP model. Uncomment the portion of code
#to generate the desired type of data.
#Parameters, determine the location where new predictions lie.
edgeGridX <- seq(0,1,length = 100)
edgeGridY <- seq(0,1,length = 100)
# In terms of UTM coordinates.
Xnew <- as.matrix(expand.grid(edgeGridX,edgeGridY))
truthFUN<-function(X1,X2){X1*sin(X2)}
X<-expand.grid(seq(-10,10,1),seq(-10,10,1))
X<-as.matrix(X)
truth<-c()
Y<-c()
for(j in 1:nrow(X)){
  truth[j]=truthFUN(X[j,1],X[j,2])
  Y[j]=truth[j]+rnorm(1)
}
prep<-read.table('test.txt')
Y<-prep[,1]
Y<-as.vector(Y)
X<-prep[,2:3]
X<-as.matrix(X)

#range01 is a force-scaled function that stipulates the scale to be on [0,1].
X1t_dat<-min(X[,1])
X2t_dat<-min(X[,2])
X1m_dat<-max(X[,1])-min(X[,1])
X2m_dat<-max(X[,2])-min(X[,2])
range01 <- function(x){(x-min(x))/(max(x)-min(x))}
X[,1]<-range01(X[,1])
X[,2]<-range01(X[,2])

X1new <- edgeGridX
X2new <- edgeGridY
#Make marginal mean and variance 0 and 1
meanY <- mean(Y)
varY <- as.numeric(var(Y))
Y = (Y - meanY)/sqrt(varY)
para=list(Yt=meanY,Ym=sqrt(varY),
          X1t=X1t_dat,X1m=X1m_dat,
          X2t=X2t_dat,X2m=X2m_dat)

##########
# Priors #
##########

#Hyperparameters for priors.

pinfo=list(m=5, #number of pseudo-inputs
           a=100, b=1, # hyp. for lambda (precision of noise) - gamma prior
           r=.1, #Parameter that controls prior of eta
           logRhoFirstLayer=-1, # logarithm (base 10) of rho in first layer
           logRhoLastLayer=-50  # logarithm (base 10) of rho in last layer
)
########
# MCMC #
########
#Parameters of the MCMC sampler.
minfo=list(Nmcmc=10, #num saved samples
           burnIn=10, #num discarded samples for burn in
           semiWidthRho=0.05, #semiwidth of the proposal uniform distribution in MH step for rho (tuned adaptively)
           semiWidthEta=0.05, #semiwidth of the proposal uniform distribution in MH step for eta (tuned adaptively)
           seed=1234) #seed of the sampler, for reproducibility

tinfo <- generateTree(list(c(0,1),c(0,1)),L = 2)

#############
# Fit Model #
#############
starting <- Sys.time()
fit <- sagp(Y, X, pinfo, minfo, tinfo, Xnew=X, sampleEta=T, sampleRho=F, storePredX=T)
ending <- Sys.time()

############
# Save PDF #
############
library(ggplot2)
ggplot()+geom_point(aes(x=X[,1],y=X[,2],col=Y),size=5)+scale_colour_viridis_c(limits = c(0, 1))
ggplot()+geom_point(aes(x=fit$Xnew[,1],y=fit$Xnew[,2],col=rowMeans(fit$mu.new)),size=5)+scale_colour_viridis_c(limits = c(-1, 1))
ggplot()+geom_point(aes(x=fit$Xnew[,1],y=fit$Xnew[,2],col=rowMeans(fit$Yhat)),size=5)+scale_colour_viridis_c(limits = c(-1, 1))


 E04FCJ Example Program Results

 On exit, the sum of squares is       0.0082
 at the point       0.0824       1.1330       2.3437
 The estimated gradient is    -1.607e-09	   -7.436e-11	    6.130e-10
                     (machine dependent)
 and the residuals are
  -5.9e-03
  -2.7e-04
   2.7e-04
   6.5e-03
  -8.2e-04
  -1.3e-03
  -4.5e-03
  -2.0e-02
   8.2e-02
  -1.8e-02
  -1.5e-02
  -1.5e-02
  -1.1e-02
  -4.2e-03
   6.8e-03


#' @title
#' Generate simulation data
#'
#' @description
#' This function generates simulation data for the nested reduced-rank
#' regression under the multivariate functional regression scenario.
#' With user-specified model dimensions and ranks,
#' this function first generates functional multivariate predictors and
#' responses and then transform the functional regression problem into a
#' conventional finite-dimensional regression problem through basis expansion
#' and truncation. The B-spline basis is used to conduct basis expansion.
#'
#' @usage
#' NRRR.sim(n, ns, nt, r, rx, ry, jx, jy, p, d,
#'          s2n, rho_X, rho_E, Sigma = "CorrAR")
#'
#' @param n sample size.
#' @param ns number of time points at which the predictor trajectory is observed.
#' @param nt number of time points at which the response trajectory is observed.
#' @param r rank of the local reduced-rank structure.
#' @param rx number of latent predictors.
#' @param ry number of latent responses.
#' @param jx number of basis functions to expand the predictor trajectory.
#' @param jy number of basis functions to expand the response trajectory.
#' @param p number of predictors.
#' @param d number of responses.
#' @param s2n a positive number to specify the signal to noise ratio.
#' @param rho_X a scalar between 0 and 1 to specify the correlation strength among covariates.
#' @param rho_E a scalar between 0 and 1 to specify the correlation strength among random errors.
#' @param Sigma the correlation structure. Two options are available,
#'              "CorrAR": autoregressive,
#'              "CorrCS": compound symmetry.
#'
#'
#' @return The function returns a list:
#'   \item{Ag}{the matrix U.}
#'   \item{Bg}{the matrix V.}
#'   \item{Al}{the matrix A.}
#'   \item{Bl}{the matrix B.}
#'   \item{C}{the coefficient matrix C.}
#'   \item{Alstar}{A* in equation (7) of the NRRR paper.}
#'   \item{Blstar}{B* in equation (7) of the NRRR paper.}
#'   \item{Cstar}{\eqn{(U \otimes I_jy)A* B*^T(V \otimes I_jx)^T} in equation (7) of the NRRR paper.}
#'   \item{tseq}{a sequence of time points at which the response trajectory is observed.}
#'   \item{psi}{the set of basis functions to expand the response trajectory.}
#'   \item{Jpsi}{the correlation matrix of psi. Jpsihalf is (Jpsi)^(1/2).}
#'   \item{sseq}{a sequence of time points at which the predictor trajectory is observed.}
#'   \item{phi}{the set of basis functions to expand the predictor trajectory.}
#'   \item{Jphi}{the correlation matrix of phi.}
#'   \item{E}{the random error matrix.}
#'   \item{Y}{an array of dimension \code{(n, d, nt)}, i.e., the generated response observations.}
#'   \item{X}{an array of dimension \code{(n, p, ns)}, i.e., the generated predictor observations.}
#'   \item{Ytrue}{an array of dimension \code{(n, d, nt)}. The response observations without random errors.}
#'   \item{Yest}{the response matrix used in NRRR estimation, and is of dimension n-by-jy*d.}
#'   \item{Xest}{the design matrix used in NRRR estimation, and is of dimension n-by-jx*p.}
#' @examples
#' library(NRRR)
#' simDat <- NRRR.sim(n = 100, ns = 200, nt = 200, r = 5, rx = 3, ry = 3,
#'                    jx = 15, jy = 15, p = 10, d = 6, s2n = 1, rho_X = 0.5,
#'                    rho_E = 0, Sigma = "CorrAR")
#' simDat$Ag
#' @importFrom stats runif rnorm sd
#' @importFrom splines bs
#' @importFrom MASS mvrnorm
#' @export
NRRR.sim <- function(n,ns,nt,r,rx,ry,jx,jy,p,d,s2n,rho_X,rho_E,Sigma="CorrAR"){

  #require(MASS)
  #require(splines)
  if(p < rx) stop("rx cannot be greater than p")
  if(d < ry) stop("ry cannot be greater than d")

  ### generate X(s) and Y(t)
  # generate uniformly distributed time points for x(s)
  sseq <- sort(stats::runif(ns,0,1))
  # generate basis functions
  phi <- splines::bs(c(0,sseq),df = jx)[-1,]
  # compute Jphi
  Jphi <- matrix(nrow=jx,ncol=jx,0)
  sdiff <- (sseq - c(0,sseq[-ns]))
  for(s in 1:ns) Jphi <- Jphi + phi[s,]%*%t(phi[s,])*sdiff[s]

  # generate X(s)
  if (Sigma == "CorrAR") {
      Sigma <- CorrAR
    } else {
      Sigma <- CorrCS
    }
  Xsigma <- Sigma(p*jx,rho_X)
  Xi <- MASS::mvrnorm(n,rep(0,p*jx),Xsigma)
  X <- array(dim=c(n,p,ns),NA)
  for(s in 1:ns){
    Phis <- kronecker(diag(nrow=p,ncol=p),t(phi[s,]))
    for(i in 1:n){
      X[i,,s] <-  Phis%*%Xi[i,]
    }
  }

  #####Bg (V) matrix, p times rx
  Bg <- qr.Q(qr(matrix(nrow=p,ncol=rx,stats::rnorm(p*rx))))
  #####Ag (U) matrix, d times ry
  Ag <- qr.Q(qr(matrix(nrow=d,ncol=ry,stats::rnorm(d*ry))))
  #####Blstar (B^*) matrix, jx*rx times r
  Blstar <- matrix(nrow=jx*rx, ncol=r, stats::rnorm(jx*rx*r))
  #####Alstar (A^*) matrix, jy*ry times r
  Alstar <- matrix(nrow=jy*ry, ncol=r, stats::rnorm(jy*ry*r))
  #####The coefficient matrix to generate Y(t)
  Cstar <- kronecker(Ag,diag(jy))%*%Alstar%*%t(Blstar)%*%kronecker(t(Bg),diag(jx))

  # Integrated X
  Xint <- matrix(nrow=p*jx,ncol=n,0)
  sdiff <- (sseq - c(0,sseq[-ns]))
  for(s in 1:ns){
    Xint <- Xint + kronecker(diag(nrow=p,ncol=p),phi[s,])%*%t(X[,,s])*sdiff[s]
  }

  # True signal Ytrue(t)
  # generate uniformly distributed time points for y(t)
  tseq <- sort(stats::runif(nt,0,1))
  # generate basis function
  psi <- splines::bs(c(0,tseq),df = jy)[-1,]
  Ytrue <- array(dim=c(n,d,nt),NA)
  Y0 <- Cstar%*%Xint
  for(t in 1:nt){
    Psit <- kronecker(diag(nrow=d,ncol=d),t(psi[t,]))
    Ytrue[,,t] <- t(Psit%*%Y0)
  }

  # The error matrix, n times d*jy
  sigma <- stats::sd(as.vector(Y0))/s2n
  E <- matrix(nrow=n,ncol=d*jy, stats::rnorm(n*d*jy,0,sigma))

  # The response matrix Y(t)
  Y <- array(dim=c(n,d,nt),NA)
  for(t in 1:nt){
    Psit <- kronecker(diag(nrow=d,ncol=d),t(psi[t,]))
    for(i in 1:n){
      Y[i,,t] <- Ytrue[i,,t]+Psit%*%E[i,]
    }
  }

  # compute Jpsi
  Jpsi <- matrix(nrow=jy,ncol=jy,0)
  tdiff <- (tseq - c(0,tseq[-nt]))
  for(t in 1:nt) Jpsi <- Jpsi + psi[t,]%*%t(psi[t,])*tdiff[t]
  eJpsi <- eigen(Jpsi)
  Jpsihalf <- eJpsi$vectors%*%diag(sqrt(eJpsi$values))%*%t(eJpsi$vectors)
  Jpsihalfinv <- eJpsi$vectors%*%diag(1/sqrt(eJpsi$values))%*%t(eJpsi$vectors)

  ### Process the data for estimation
  Xa <- array(dim=c(n,p,jx),NA)
  sdiff <- (sseq - c(0,sseq[-ns]))
  for(i in 1:n){
    for(l in 1:p){
      for(j in 1:jx){
        Xa[i,l,j] <- sum(phi[,j]*X[i,l,]*sdiff)    # integrate over s
      }
    }
  }

  Ya <- array(dim=c(n,d,jy),NA)
  tdiff <- (tseq - c(0,tseq[-nt]))
  psistar <- psi%*%Jpsihalfinv
  for(k in 1:d){
    for(i in 1:n){
      for(j in 1:jy){
        Ya[i,k,j] <- sum(psistar[,j]*Y[i,k,]*tdiff) # integrate over t
      }
    }
  }

  # Y and X matrices for estimation
  Yest <- Ya[,,1]
  for(j in 2:jy) Yest <- cbind(Yest,Ya[,,j])
  Xest <- Xa[,,1]
  for(j in 2:jx) Xest <- cbind(Xest,Xa[,,j])

  # C matrix in estimation
  Alstaradj <-  kronecker(diag(ry),Jpsihalf)%*%Alstar
  alindex <- rep(1:jy,ry)
  Al <- Alstaradj[order(alindex),]
  blindex <- rep(1:jx,rx)
  Bl <- Blstar[order(blindex),]
  C <- kronecker(diag(jx),Bg)%*%Bl%*%t(Al)%*%kronecker(diag(jy),t(Ag))

  list(Ag=Ag,Bg=Bg,Alstar=Alstar,Blstar=Blstar,Cstar=Cstar,
       Al=Al, Bl=Bl, C=C,
       sseq=sseq,psi=psi,Jpsi=Jpsi,Jpsihalf=Jpsihalf,
       tseq=tseq,phi=phi,Jphi=Jphi,
       E=E,
       Y=Y,X=X,Ytrue=Ytrue,
       Yest=Yest,Xest=Xest)

}


library("ggplot2")
library("tidyr")
data <- read.csv("perm_data/index_inner_join.csv")
df_no_index <- subset(data, type=="no index")
df_no_index <- df_no_index[c("num_rows", "time")]
constant <- median(df_no_index$time/df_no_index$num_rows ^2)
df_no_index$fitted <- constant * df_no_index$num_rows ^2
colnames(df_no_index) <- c("num_rows", "actual", "fitted")
df_tidy <- gather(df_no_index, type, time, -num_rows)
ggplot(data = df_tidy, aes(x=num_rows, y= time, color = type)) +
	geom_line() +
	ggtitle("No Index") +
	ylab("time in seconds") +
	scale_x_continuous(name="number rows", labels = scales::comma)
ggsave("data_out/no_index.png")