#' Power calculations in an experiment with group clusters.
#'
#' @param unclustered Results from twomeans not adjusting for clusters
#' @param rho Specifies the intraclass correlation coefficient
#' @param obsclus Number of observations in each cluster
#' @param numclus Maximum number of clusters
#' @return returns an object with all the study parameters
#' @export
#' @importFrom magrittr %>%
#' @examples
#' twomeans(m1 = 12, m2 = 16, sd = 5) %>% clustered(obsclus = 10, rho = 0.3)
clustered <- function(unclustered, rho, obsclus = NULL, numclus = NULL) {

  if(is.null(numclus)) {
    deff    <- 1 + (obsclus - 1) * rho
    n1clus  <- unclustered$n1 * deff
    n2clus  <- unclustered$n2 * deff
    numclus <- (n1clus + n2clus) / obsclus
  }

  if(is.null(obsclus)) {
    tot <- (unclustered$n1 * (1 - rho) + unclustered$n2 * (1 - rho)) /
           (1 - (unclustered$n1 * rho / numclus) -
           (unclustered$n1 * rho / numclus))
    if(tot <= 0) {
      stop("Number of clusters is too small.")
    }
    obsclus <- ceiling(tot / numclus)
    deff    <- 1 + (obsclus - 1) * rho
    n1clus  <- unclustered$n1 * deff
    n2clus  <- unclustered$n2 * deff
  }

  # Round everyone
  n1clus  <- ceiling(n1clus)
  n2clus  <- ceiling(n2clus)
  obsclus <- ceiling(obsclus)
  numclus <- ceiling(numclus)

  METHOD = "Two-sample t-test power calculation"
  NOTE   = paste("m1 and m2 are the means of group 1 and 2, respectively.",
                 "n1 and n2 are the obs. of group 1 and 2, respectively.",
                 sep = "\r\n")

    structure(list(m1                           = unclustered$m1,
                   m2                           = unclustered$m2,
                   "n1 (unadjusted)"            = unclustered$n1,
                   "n2 (unadjusted)"            = unclustered$n2,
                   rho                          = rho,
                   "Average per cluster"        = obsclus,
                   "Minimum number of clusters" = numclus,
                   "n1 (adjusted)"              = n1clus,
                   "n2 (adjusted)"              = n2clus,
                   sig.level                    = unclustered$sig.level,
                   power                        = unclustered$power,
                   alternative                  = "two.sided",
                   method                       = METHOD,
                   note                         = NOTE),
                   class                        = "power.htest")

}

.check.clustered <- function(unclustered, rho, obsclus = NULL, numclus = NULL) {
  if(all(is.null(obsclus), is.null(numclus))) {
    stop("Either obsclus or numclus must be specified.")
  }
}


library(raster)
library(fields)
source("C:/GitHub/R_bits/my_functions/plotting.r")
source("C:/GitHub/synthetic_channels/meshing/development_scripts/parabola_funcs_where_obs_available.r")

Nth.row <- function(dataframe, n) dataframe[(seq (n, to=nrow(dataframe), by=n)),]

spline_surface<-function(xyz, plotting=F){

  combo=as.data.frame(xyz)

  fit<- Tps(combo$x, combo$y)

  coord<-data.frame(combo$x, combo$y)
  z<-data.frame(combo$z)

  fit<-Tps(coord,z)

  xg<-make.surface.grid(fields.x.to.grid(coord)) # makes a mesh grid of x and y
  if (plotting==TRUE){plot(xg)} # displays the mesh grid
  fhat<- predict( fit, xg) # indexes values of based on the thin plate spline to their xy index locations (i.e. this is 1d and is therefore a length of the dimensions of plot(xg))
  out.p<- as.surface( xg, fhat)

  return(out.p)
}

points_all=read.csv("C:/GitHub/synthetic_channels/USED_FOR_SYNTH_PAPER/site_aoi_Fenty_N/bamber2013_aoi_Fenty_N_gt500m_mc.csv")

points=Nth.row(points_all, 20)
keep=c('x','y','z')
points=points[keep]
out.p=spline_surface(points)

out.p.agg=aggregate(out.p)
###################
# plot it

persp(out.p$x, out.p$y, out.p$z*5,
      phi = 20, theta = 20,
      xlab = "easting (m)", ylab = "northing (m)", zlab="elevation (m)", scale=FALSE, expand=1,
      r=10,
      d=0.4 )-> res
      #main = "Surface spline"

#points(trans3d(points$x, points$y, points$z, pmat = res), col = 2, pch = 20, cex = 0.7)  # add points to wireframe plot
points(trans3d(points$x, points$y, points$z, pmat = res), col = 2, pch = 18, cex = 0.5)  # add points to wireframe plot


wheat <- read.csv("http://archive.ics.uci.edu/ml/machine-learning-databases/00236/seeds_dataset.txt", sep="\t")

colnames(wheat) <- c("area","perimeter","compactness","length","width","asymmetry","groove","undefined")

wheat <- wheat[complete.cases(wheat),]

fit <- kmeans(wheat, 5)

fit


#' Weight of Evidence and Information Value in Credit Scoring
#'
#' Calculate Information Value and Weight of Evidence for variables in data frame. Information Value is used in credit scoring to compare predictive power among variables.
#' Weight of Evidence (WoE): \deqn{WoE = \ln(\frac{\%good_i}{\%bad_i})}
#' Information Value:
#' \deqn{IV = \Sigma_{i=1}^{n}(\ln(\frac{\%good_i}{\%bad_i})*(\%good_i - \%bad_i))}
#' @docType package
#' @name woe
#' @import ggplot2
#' @importFrom plyr rbind.fill
#' @importFrom RColorBrewer brewer.pal
#' @import rpart
#' @importFrom sqldf sqldf
NULL


# Function to apply MAUT model to get ranking of alternatives

maut<-function(gdata,nI,J,K,ta,la,u_c){

  u=array(rep(0,nI*J*K),c(nI,J,K))
  wutil=array(rep(0,nI*J*K),c(nI,J,K))
  U_k=array(rep(0,nI*J),c(nI,J))

  w=sort(wts2(J),decreasing=T)

  for(j in 1:J)
  {
    cutoffs = c(0,ta[j],1)
    values = c(0,la[j],1)
    xt = as.vector(gdata[,j,])
    xt_pvf = smaa.pvf(xt,cutoffs=cutoffs,values=values,outOfBounds="clip")
    u[,j,] = matrix(xt_pvf,nI,K)
    wutil[,j,] = u[,j,] * w[j]
  }

  for(m in 1:nI)
  {
    U_k[m,] <- apply(wutil[m,,],1,sum)
  }
  value_f <- apply(U_k,1,sum)/K

  if(u_c > 0){
    utility = -exp(-u_c * value_f)
  } else if (u_c < 0){
    utility = exp(-u_c * value_f)
  } else { utility = value_f}

  list(utility=utility,w=w)
}


# Adapted from http://horn.tau.ac.il/software/qc.m
#
# David Horn and Assaf Gottlieb.  Algorithm for Data Clustering Pattern
# Recognition Problems Based on Quantum Mechanics (Physical Review Letters
# 88, 2002).

#' Summarize standard deviation
#'
#' Summarize the standard deviation of a data set with multiple columns into a single value.  This function accomplishes this task by finding the length of a vector containing the standard deviation of each column.  This function may be useful in establishing a \code{sigma} for qc().
#'
#' @param dataset The cleaned input data to be clustered in either data.frame or matrix format.  This should contain only numeric data and must not have any factors, strings, NAs, etc.  It also should not contain any irrelevant columns such as observation ID or redundant data.
#'
#' @return The function returns a double containing the approximated standard deviation of the entire data set.
#'
#' @examples
#' data(iris)
#' iris_data <- iris[, -5] # Drop the species factor
#' sigma <- 0.4 * calcSD(iris_data)
#'
#' @export
calcSD <- function(dataset) {
    sd <- c()
    p <- ncol(dataset)

    if(is.null(p)) {
        sd <- sd(dataset)
    } else {
        for(i in seq(1, p)) {
            sd <- c(sd, sd(dataset[, i]))
        }
        sd <- (sum(sd^2)) ^ (1/2)
    }

    sd
}

#' Cluster data
#'
#' Cluster data using a non-linear clustering algorithm which finds organic groups of data from eigenfunctions and does not suffer from the curse of dimensionality.  The algorithm is approximately O(n^2).
#'
#' @param dataset The cleaned input data to be clustered in either data.frame or matrix format.  This should contain only numeric data and must not have any factors, strings, NAs, etc.  It also should not contain any irrelevant columns such as observation ID or redundant data.
#' @param sigma A double which controls how closely related data in clusters should be.  The smaller the number, more clusters will be created with fewer observations in each.  If sigma is too small, observations either will not be clustered or will be in their own individual clusters.  If sigma is too large, most -- if not all -- observations will be in the first cluster.
#' @param steps An integer specifying the number of expectation-maximization steps to take.  If faster, less accurate results are required, this may be reduced from the default of 21.
#' @param min_d_factor A double which controls how close data points must be in order to be considered in the same cluster.  Specifically, this value is the number of sigmas of distance to be within said threshold.  This value should probably not be changed unless there is a strong reason to do so.
#' @param n_clusters_max An integer specifying the maximum number of clusters to return.  These clusters will always be the most common clusters with the most observations in them.
#' @param verbose A boolean value which toggles the algorithm's verbosity for details as to how far along it is.
#'
#' @return The function returns a vector of the numeric clusters assigned to each row in \code{dataset}.
#'
#' @examples
#' # Set up parallel execution
#' library(doMC)
#' registerDoMC(cores=2) # Replace `2` with the number of cores in your machine
#'
#' data(iris)
#' iris_data <- iris[, -5] # Remove the classification of the iris data set
#' clusters <- qc(iris_data, 1.0)
#' secondary_cluster_rows <- which(clusters == 2)
#' print(iris[secondary_cluster_rows, ])
#'
#' @export
qc <- function(dataset, sigma, steps=21, min_d_factor=2,
               n_clusters_max=1000, verbose=FALSE) {

    ETA_DECAY <- 0.9

    main <- function(dataset, sigma, steps, min_d_factor,
                     n_clusters_max) {
        min_d <- getMinD(sigma, min_d_factor)
        eta <- getEta(sigma)
        q <- getQ(sigma)

        qc_log(paste0("Starting gradient decent with sigma ", sigma,
                      " and q ", q))
        D <- gradDesc(dataset, dataset, q, steps, eta, steps)
        qc_log("Gradient descent done")

        derived_clusters <- assignClusters(D, min_d, n_clusters_max)
        derived_clusters
    }

    gradDesc <- function(data_points, D, q, init_steps, eta, steps) {

        vecNorm <- function(v) {
            squared_sum <- sum(v^2)
            if(squared_sum == 0) {
                return(v)
            }

            # A new variable would be preferred, but for performance purposes,
            # overwrite in order to avoid reallocating a new vector
            v <- v / sqrt(squared_sum)
            v
        }

        start <- Sys.time()
        dV <- gradient(data_points, q, D)
        dV <- t(apply(dV, MARGIN=1, FUN=vecNorm))
        qc_log(paste0("Gradient descent step: ", (init_steps - steps) + 1,
                      " done"))
        endtime <- Sys.time()
        qc_log(endtime - start)

        # Faster to overwrite and avoid allocating a new matrix
        D <- D - eta * dV
        eta <- eta * ETA_DECAY

        if (steps <= 1) {
            D
        }
        else {
            gradDesc(data_points, D, q, init_steps, eta, (steps - 1))
        }
    }

    gradient <- function(ri, q, r=ri) {
        n <- nrow(ri)
        p <- ncol(ri)

        V <- matrix(0, n, 1)
        dP2 <- matrix(0, n, 1)
        P <- matrix(0, n, 1)

        dV1 <- matrix(0, n, p)
        dV2 <- matrix(0, n, p)
        dV <- matrix(0, n, p)

        point_iter <- seq(1, n)
        results <- foreach(point=point_iter,
                           .combine=c, .inorder=TRUE) %dopar% {
            calcPoint(point, r, ri, n, q, p)
        }

        # Merge the results from the list returned above
        # (No clean multiple assignment in R working with foreach results)
        result_offset <- 4
        for(point in point_iter) {
            list_index <- point - 1
            curr_index <- list_index * result_offset

            P[point] <- results[[curr_index + 1]]
            dP2[point] <- results[[curr_index + 2]]
            dV1[point, ] <- results[[curr_index + 3]]
            dV2[point, ] <- results[[curr_index + 4]]
        }

        P_zero_ind = which(P == 0)
        if(length(P_zero_ind) > 0) {
            P_non_zero_min <- min(P[-P_zero_ind])
            P[P_zero_ind] <- P_non_zero_min
        }

        V <- -p/2 + q*dP2/P
        E <- -min(V)
        V <- V + E

        for(dim in seq(1, p)) {
            dV[, dim] <- -q*dV1[, dim] + (V - E + (p + 2) / 2) * dV2[, dim]
        }
        dV[P_zero_ind, ] <- 0

        dV
    }

    calcPoint <- function(point, r, ri, n, q, p) {

        repRow <- function(X, row_reps, col_reps){
            p <- length(X)
            matrix(X, row_reps, p, byrow=T)
        }

        empty_col <- matrix(0, n, 1)
        empty_row <- matrix(0, 1, p)
        empty_matrix <- matrix(0, n, p)

        single_laplace <- empty_col
        dV1 <- empty_row
        dV2 <- empty_row

        squared_matrix <- repRow(r[point, ], n, 1)
        squared_matrix <- squared_matrix - ri
        unsquared_mat <- squared_matrix
        squared_matrix <- squared_matrix^2

        D2 <- apply(squared_matrix, MARGIN=1, FUN=sum)
        single_point <- exp(-q * D2)

        for(dim in seq(1, p)) {
            single_laplace <- single_laplace + squared_matrix[, dim] *
                              single_point
        }

        for(dim in seq(1, p)) {
            curr_col <- unsquared_mat[, dim]
            dV1[, dim] <- dV1[, dim] + sum(curr_col * single_laplace)
            dV2[, dim] <- dV2[, dim] + sum(curr_col * single_point)
        }

        P <- sum(single_point)
        dP2 <- sum(single_laplace)

        results <- list(P=P, dP2=dP2, dV1=dV1, dV2=dV2)
        results
    }

    assignClusters <- function(data_points, min_d, n_clusters_max) {

        isAssigned <- function(clusters, index) {
            clusters[index] != 0
        }

        qc_log("Assigning clusters")

        n <- nrow(data_points)
        p <- ncol(data_points)
        clusters <- rep(0, n)
        label <- 1
        start_index = 1

        for (start_index in seq(1, n)) {

            if (min(clusters) > 0) {
                break
            }

            if (!isAssigned(clusters, start_index)) {

                clusters[start_index] <- label
                for(row in seq(start_index, n)) {
                    if (!isAssigned(clusters, row)) {
                        ref_dist <- distance(data_points[start_index, ],
                                             data_points[row, ])
                        if (ref_dist <= min_d) {
                            clusters[row] <- label
                        }
                    }
                }

                label <- label + 1
            }
        }

        clusters
    }

    getMinD <- function(sigma, min_d_factor=2) {
        min_d_factor * sigma
    }

    getEta <- function(sigma) {
        sigma / 2.5
    }

    getQ <- function(sigma) {
        1 / (2 * sigma^2)
    }

    distance <- function(x, y) {
        sqrt(sum((x - y) ^ 2))
    }

    qc_log <- function(out_text) {
        if(verbose) {
            print(out_text)
        }
    }

    orderClusters <- function(training, derived_clusters, n_clusters_max) {

        getPopularClusters <- function(derived_clusters, n_clusters_max) {
            popular_clusters_table <- tail(sort(table(derived_clusters)),
                                           n=n_clusters_max)
            popular_clusters <- rev(as.integer(names(popular_clusters_table)))
            popular_clusters
        }

        popular_clusters <- getPopularClusters(derived_clusters,
                                               n_clusters_max)

        clusters <- rep(0, nrow(training))
        i <- 1
        for(label in popular_clusters) {
            clusters[which(derived_clusters == label)] <- i
            i <- i + 1
        }

        clusters
    }

    dataset <- as.matrix(dataset)
    derived_clusters <- main(dataset, sigma, steps, min_d_factor,
                             n_clusters_max)
    ordered_clusters <- orderClusters(dataset, derived_clusters,
                                      n_clusters_max=n_clusters_max)
    ordered_clusters
}


ggplotRegression <- function (fit) {
  require(ggplot2)
  titlesigfig <- 5
  ggplot(fit$model, aes_string(x = names(fit$model)[2], y = names(fit$model)[1])) +
    geom_point() +
    stat_smooth(method = "lm", col = "red") +
    labs(title = paste("Adj R2 = ",signif(summary(fit)$adj.r.squared, titlesigfig),
                       "Intercept =",signif(fit$coef[[1]],titlesigfig),
                       " Slope =",signif(fit$coef[[2]], titlesigfig),
                       " P =",signif(summary(fit)$coef[2,4], titlesigfig)))
}
#fit <- lm(hwy ~ displ, data=mpg)
#ggplotRegression(fit)


 install.packages(c("RColorBrewer", "cluster", "pvclust", "xtable", "plyr"))
 library(RColorBrewer)
 library(cluster)
 library(pvclust)
 library(xtable)
 library(plyr)

 GSE4051_data <- read.csv("d:/GSE4051_data.csv", header = TRUE)
 str(GSE4051_data, max.level = 0)
'data.frame':	29949 obs. of  39 variables:

 GSE4051_design <- read.csv("d:/GSE4051_design.csv", header = TRUE)
 str(GSE4051_design)
'data.frame':	39 obs. of  4 variables:
 $ sidChar : Factor w/ 39 levels "Sample_1","Sample_10",..: 13 14 15 16 8 9 36 17 18 19 ...
 $ sidNum  : int  20 21 22 23 16 17 6 24 25 26 ...
 $ devStage: Factor w/ 5 levels "4_weeks","E16",..: 2 2 2 2 2 2 2 4 4 4 ...
 $ gType   : Factor w/ 2 levels "NrlKO","wt": 2 2 2 2 1 1 1 2 2 2 ...

 trans_GSE4051_data <- t(scale(t(GSE4051_data)))
 str(trans_GSE4051_data, max.level = 0, give.attr = FALSE)
 num [1:29949, 1:39] 0.0838 0.1758 0.7797 -0.3196 0.8358 ...

 round(data.frame(avgBefore = rowMeans(head(GSE4051_data)),
                 avgAfter = rowMeans(head(trans_GSE4051_data)),
                 varBefore = apply(head(GSE4051_data), 1, var),
                 varAfter = apply(head(trans_GSE4051_data), 1, var)), 2)
  avgBefore avgAfter varBefore varAfter
1      7.22        0      0.02        1
2      9.37        0      0.35        1
3      9.70        0      0.15        1
4      8.42        0      0.03        1
5      8.47        0      0.02        1
6      9.67        0      0.03        1

 pair_dist_GSE4051_data <- dist(t(trans_GSE4051_data), method = 'euclidean')

 GSE4051_design$group <- with(GSE4051_design, interaction(gType, devStage))
 summary(GSE4051_design$group)
NrlKO.4_weeks    wt.4_weeks     NrlKO.E16        wt.E16     NrlKO.P10        wt.P10      NrlKO.P2         wt.P2      NrlKO.P6
            4             4             3             4             4             4             4             4             4
        wt.P6
            4

 pr.hc.single <- hclust(pair_dist_GSE4051_data, method = 'single')
 pr.hc.single
Call:
hclust(d = pr.dis, method = "single")

Cluster method   : single
Distance         : euclidean
Number of objects: 39

 pr.hc.complete <- hclust(pair_dist_GSE4051_data, method = 'complete')
 pr.hc.complete

Call:
hclust(d = pr.dis, method = "complete")

Cluster method   : complete

 pr.hc.average <- hclust(pair_dist_GSE4051_data, method = 'average')
 pr.hc.average

Call:
hclust(d = pr.dis, method = "average")

Cluster method   : average
Distance         : euclidean
Number of objects: 39

 pr.hc.ward <- hclust(pair_dist_GSE4051_data, method = 'ward.D2')
 pr.hc.ward

Call:
hclust(d = pr.dis, method = "ward.D2")

Cluster method   : ward.D2
Distance         : euclidean
Number of objects: 39

Distance         : euclidean
Number of objects: 39

 op <- par(mar = c(0,4,4,2), mfrow = c(2,2))

 plot(pr.hc.single, labels = FALSE, main = "Single Linkage Representation", xlab = "")

 plot(pr.hc.complete, labels = FALSE, main = "Complete Linkage Representation", xlab = "")

 plot(pr.hc.average, labels = FALSE, main = "Average Linkage Representation", xlab = "")

 plot(pr.hc.ward, labels = FALSE, main = "Ward Linkage Representation", xlab = "")

 par(op)

 op <- par(mar = c(1,4,4,1))

 plot(pr.hc.single, labels = GSE4051_design$group, cex = 0.6, main = "Single Hierarchical Cluster - 10 clusters")
 rect.hclust(pr.hc.single, k = 10)
 par(op)
 jGraysFun <- colorRampPalette(brewer.pal(n = 9, "Blues"))
 gTypeCols <- brewer.pal(9, "Spectral")[c(4,7)]
 heatmap(as.matrix(trans_GSE4051_data), Rowv = NA, col = jGraysFun(256), hclustfun = function(x) hclust(x, method = 'single'),
	scale = "none", labCol = GSE4051_design	$group, labRow = NA, margins = c(8,1),
	ColSideColor = gTypeCols[unclass(GSE4051_design$gType)])
 legend("topright", legend = levels(GSE4051_design$gType), col = gTypeCols, lty = 1, lwd = 5, cex = 0.5)

 plot(pr.hc.complete, labels = GSE4051_design$group, cex = 0.6, main = "Complete Hierarchical Cluster - 10 clusters")
 rect.hclust(pr.hc.complete, k = 10)
 par(op)
 jGraysFun <- colorRampPalette(brewer.pal(n = 9, "Greens"))
 gTypeCols <- brewer.pal(11, "PRGn")[c(4,7)]
 heatmap(as.matrix(trans_GSE4051_data), Rowv = NA, col = jGraysFun(256), hclustfun = function(x) hclust(x, method = 'complete'),
	scale = "none", labCol = GSE4051_design$group, labRow = NA, margins = c(8,1),
	ColSideColor = gTypeCols[unclass(GSE4051_design$gType)])
 legend("topright", legend = levels(GSE4051_design$gType), col = gTypeCols, lty = 1, lwd = 5, cex = 0.5)

 plot(pr.hc.average, labels = GSE4051_design$group, cex = 0.6, main = "Average Hierarchical Cluster - 10 clusters")
 rect.hclust(pr.hc.average, k = 10)
 jGraysFun <- colorRampPalette(brewer.pal(n = 9, "Oranges"))
 gTypeCols <- brewer.pal(9, "Oranges")[c(4,7)]
 heatmap(as.matrix(trans_GSE4051_data), Rowv = NA, col = jGraysFun(256), hclustfun = function(x) hclust(x, method = 'average'),
	scale = "none", labCol = GSE4051_design$group, labRow = NA, margins = c(8,1),
	ColSideColor = gTypeCols[unclass(GSE4051_design$gType)])
 legend("topright", legend = levels(GSE4051_design$gType), col = gTypeCols, lty = 1, lwd = 5, cex = 0.5)

 plot(pr.hc.ward, labels = GSE4051_design$group, cex = 0.6, main = "Ward Hierarchical Cluster - 10 clusters")
 rect.hclust(pr.hc.ward, k = 10)
 jGraysFun <- colorRampPalette(brewer.pal(n = 9, "Reds"))
 gTypeCols <- brewer.pal(9, "Reds")[c(4,7)]
 heatmap(as.matrix(trans_GSE4051_data), Rowv = NA, col = jGraysFun(256), hclustfun = function(x) hclust(x, method = 'ward.D2'),
	scale = "none", labCol = GSE4051_design$group, labRow = NA, margins = c(8,1),
	ColSideColor = gTypeCols[unclass(GSE4051_design$gType)])
 legend("topright", legend = levels(GSE4051_design$gType), col = gTypeCols, lty = 1, lwd = 5, cex = 0.5)

Chapter 03/3Hierarchical Clustering - Gene Clustering.r


library(tidyverse)
library(recommenderlab)

## Entrada dos dados

dados_books = read_csv("dados_books_2017_2018_min5.csv")

head(dados_books)
dim(dados_books)
summary(dados_books)
hist(dados_books$rating, breaks = "sturges",
     main="Histograma - Ratings",
     ylab = "Frequência", xlab = "Ratings")

##Amostragem

set.seed(2020)
user_ids = unique(dados_books$user)
amostra_user = sample(user_ids, round(0.02 * length(user_ids)))

dados_books_amostra = dados_books %>% filter(user %in% amostra_user)

#verifica se todos users e itens tem pelo menos 1 review
dados_books_amostra = dados_books_amostra %>% group_by(user, item) %>%
  mutate(n = n()) %>% filter(n == 1) %>% ungroup()
dados_books_amostra$n = NULL
dados_books_amostra = as.data.frame(dados_books_amostra)

dim(dados_books_amostra)

##Matriz de ratings

mr_dados = as(dados_books_amostra, "realRatingMatrix")
mr_dados

summary(rowCounts(mr_dados))
summary(colCounts(mr_dados))

##Avaliação de algoritmos TopN

evalScheme = evaluationScheme(mr_dados, method = "cross", k = 5,
                              train = 0.8, given = 5, goodRating = 4)
evalScheme

nlists = c(1,5,10,15,20)

#modelos possíveis
recommenderRegistry$get_entry("Popular", dataType = "realRatingMatrix")

models = list(
  'Random' = list(name="RANDOM", param = NULL),
  'Popular' = list(name="POPULAR", param = NULL))

results = evaluate(evalScheme, models, type="topNList", n = nlists)
results

models2 = list('ALS' = list(name="ALS", param = NULL),
               'ALS imp' = list(name="ALS_implicit", param = NULL))
results2 = evaluate(evalScheme, models2, type="topNList", n = nlists)
results2

#plot ROC - True Positive x False Positive
plot(results, annotate = c(1,2), legend = "topleft")

#plot Precision x Recall
plot(results, "prec/rec", annotate = c(1,2), legend = "topright")

#plot média dos runs com ggplot

avg_conf_matr <- function(results) {
  tmp <- results %>% getConfusionMatrix() %>% as.list()
  as.data.frame(Reduce("+",tmp) / length(tmp)) %>%
    mutate(n = c(1,5,10,15,20)) %>%
    select('n', 'precision', 'recall', 'TPR', 'FPR')
}

results_tbl <- results %>% map(avg_conf_matr) %>% enframe() %>% unnest(cols = c(value))
results_tbl2 <- results2 %>% map(avg_conf_matr) %>% enframe() %>% unnest(cols = c(value))

results_tbl_all = rbind(results_tbl, results_tbl2)

#write_csv(results_tbl_all, "resultados.csv")

results_tbl_all %>%
  ggplot(aes(FPR, TPR, colour = fct_reorder2(as.factor(name), FPR, TPR))) +
  geom_line() + geom_label(aes(label = n))  +
  labs(title = "Curvas ROC", colour = "Modelo") +
  theme_grey(base_size = 14)

results_tbl_all %>%
  ggplot(aes(recall, precision, colour = fct_reorder2(as.factor(name), FPR, TPR))) +
  geom_line() + geom_label(aes(label = n))  +
  labs(title = "Precision x Recall", colour = "Modelo") +
  theme_grey(base_size = 14)

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

##Modelo de recomendação final

dim(mr_dados)

trainData = mr_dados[1:2600,]
testData = mr_dados[2601:2604,]

modelRec = Recommender(trainData, "ALS_implicit")
predict = predict(modelRec, testData, n = 5)

#recomendações por usuário
as(predict, "list")

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

##Cold start - produtos mais populares

mr_dados_cold = as(as.data.frame(dados_books), "realRatingMatrix")
mr_dados_cold

modelRec_cold = Recommender(mr_dados_cold, "Popular")
predict_cold = predict(modelRec_cold, mr_dados_cold[1,], n = 20)

#recomendações Cold Start
as(predict_cold, "list")


library(recommenderlab)

# 사용 가능한 데이터
data_package <- data(package = "recommenderlab")
data_package$results[, c("Item", "Title")]

# Jester5k Load
data(Jester5k)
Jester5k
dim(Jester5k)

# EDA
## Distribution of Ratings
hist(
    getRatings(Jester5k),
    main = "Distribution of ratings"
)

# Distribution of Mean Ratings
table(rowCounts(Jester5k))
model_data <- Jester5k[rowCounts(Jester5k) < 80]
dim(model_data)
boxplot(rowMeans(model_data))
boxplot(
    rowMeans(
        model_data[rowMeans(model_data) >= -5 & rowMeans(model_data) <= 7]
    )
)

# Preprocess Dataset
model_data <- model_data[rowMeans(model_data) >= -5 & rowMeans(model_data) <= 7]
dim(model_data)
image(
    model_data[1:100, ],
    main = "Rating Distribution of 100 users"
)

# Modeling with Evaluation (k-fold): User Based CF
items_to_keep <- 30
rating_threshold <- 3
n_fold <- 5
precentage_training <- 0.8
eval_sets <- evaluationScheme(
    data = model_data,
    method = "cross-validation",
    train = precentage_training,
    given = items_to_keep,
    goodRating = rating_threshold,
    k = n_fold
)
eval_sets
getData(eval_sets, "train")
getData(eval_sets, "known")
getData(eval_sets, "unknown")

# Modeling
model_to_evaluate <- "UBCF"
model_parameters <- NULL

eval_recommender <- Recommender(
    data = getData(eval_sets, "train"),
    method = model_to_evaluate,
    parameter = model_parameters
)
eval_recommender

# Prediction
items_to_recommend <- 10
eval_prediction <- predict(
    object = eval_recommender,
    newdata = getData(eval_sets, "known"),
    n = items_to_recommend,
    type = "ratings"
)
eval_prediction

# Evaluation
eval_accuracy <- calcPredictionAccuracy(
    x = eval_prediction,
    data = getData(eval_sets, "unknown"),
    byUser = TRUE
)
head(eval_accuracy)
apply(eval_accuracy, 2, mean)

eval_accuracy <- calcPredictionAccuracy(
    x = eval_prediction,
    data = getData(eval_sets, "unknown"),
    byUser = FALSE
)
eval_accuracy

results <- evaluate(
    x = eval_sets,
    method = model_to_evaluate,
    n = seq(10, 100, 10)
)

head(getConfusionMatrix(results)[[1]])

columns_to_sum <- c("TP", "FP", "FN", "TN")
indices_summed <- Reduce("+", getConfusionMatrix(results))[, columns_to_sum]
indices_summed
plot(results, annotate = TRUE, main = "ROC curve")

############################################
# Modleing without Evaluation
# User Based CF Modeling
head(as(Jester5k, "matrix")[, 1:10])

## 1. Train Test Split
set.seed(1)
which_train <- sample(
    x = c(TRUE, FALSE),
    size = nrow(Jester5k),
    replace = TRUE,
    prob = c(0.8, 0.2)
)
rec_data_train <- Jester5k[which_train, ]
rec_data_test <- Jester5k[!which_train, ]
dim(rec_data_train)
dim(rec_data_test)

## 2. Modeling
recommender_models <- recommenderRegistry$get_entries(
    dataType = "realRatingMatrix"
)
names(recommender_models)
recommender_models

recc_model <- Recommender(
    data = rec_data_train,
    method = "UBCF"
)
recc_model

## 3. Prediction
n_recommended <- 10
recc_predicted <- predict(
    object = recc_model,
    newdata = rec_data_test,
    n = n_recommended
)
recc_predicted
rec_list <- sapply(
    recc_predicted@items,
    function(x) {
        colnames(Jester5k)[x]
    }
)
rec_list[100:101]
number_of_items <- sort(unlist(lapply(rec_list, length)), decreasing = TRUE)
table(number_of_items)


#Series temporais e analises preditivas - Fernando Amaral
library(urca)
library(forecast)

#teste de estacionariedade
x = ur.kpss(AirPassengers)
print(x)

#faz a diferenciacao
z = diff(AirPassengers)
#testa novamente
x = ur.kpss(z)
print(x)

split.screen( figs = c( 2, 1 ) )
screen(1)
plot(AirPassengers)
screen(2)
plot(z)
close.screen( all = TRUE )

Udemy/Series Temporais e Analises Preditivas/Resources/Codigo/5.2.Teste de Estacionariedade.r


# ----------------------------------------
#  App Title: Chaos Game -- 3 Dimensions
#     Author: Jimmy Doi
# ----------------------------------------

options(rgl.useNULL=TRUE)

if (!require("shiny")) install.packages("shiny")
if (!require("shinyBS")) install.packages("shinyBS")
if (!require("shinyRGL")) install.packages("shinyRGL")
if (!require("devtools")) install.packages("devtools")
if (!require("RColorBrewer")) install.packages("RColorBrewer")
if (!require("rgl")) install.packages("rgl")
if (!require("rglwidget")) install.packages("rglwidget")

library(shiny)
library(shinyBS)
library(shinyRGL)
library(rgl)
library(rglwidget)

shinyUI(fluidPage(

  h3("Chaos Game: Three Dimensions"),

  div("Note: Please adjust width of browser if only one column is visible.",br(),
  span(HTML("[Click here for another Shiny app on the Chaos Game]")),
    style = "font-size: 9pt;color:teal"),br(),

  p("In the 3 dimensional version of the ", HTML("
                                                 Chaos Game"),
    "we start with a regular polyhedron and mark selected
    points which will typically be the vertices. These points will be called",
    tags$i("endpoints"), "and will be marked with red squares. The game begins by randomly choosing a
    starting point and one of the endpoints.
    Mark a new point at a fixed distance ratio from the starting point to the endpoint (e.g.,
    halfway to the endpoint). Select another endpoint at random and,
    with the most recently created point, repeat the process to generate the next point
    and continue. By applying the right distance ratio the resulting set of points can converge
    to a beautiful image known as a", HTML("fractal."),"For each polyhedron the required
    distance ratio to yield a fractal will be provided,
    but try different settings to see what other patterns may arise!"
    ),
  br(),

  # Sidebar with a slider input for number of points
  sidebarPanel(
       tags$head(tags$link(rel = "icon", type = "image/x-icon", href =
   "https://webresource.its.calpoly.edu/cpwebtemplate/5.0.1/common/images_html/favicon.ico")),

  tags$title("Chaos Game -- 3 Dimensions"),
    selectizeInput('shape', h5('Shape'), choices = list(
    "Three Dimensions" = c(`Tetrahedron` = 'tetra',
                     `Cube` = 'cube',
                     `Dodecahedron` = 'dodec')
    ), selected = 'tetra'),br(),

    conditionalPanel(
      condition = "input.shape=='tetra'",
        sliderInput("dist.tetra",
                    label = h5("Distance ratio to endpoint:"),
                    min = 0.01, max = .99, value = .50, step=.01),
      div("For", tags$b("Tetrahedron"), "default value is 0.50",
          style = "font-size: 9.5pt;color:teal",align="left")
      ),
    conditionalPanel(
      condition = "input.shape=='cube'",
        sliderInput("dist.cube",
                    label = h5("Distance ratio to endpoint:"),
                    min = 0.01, max = .99, value = .67, step=.01),
      div("For", tags$b("Cube"), "default value is 0.67 (2/3)",
          style = "font-size: 9.5pt;color:teal",align="left")
      ),
    conditionalPanel(
      condition = "input.shape=='dodec'",
        sliderInput("dist.dodec",
                    label = h5("Distance ratio to endpoint:"),
                    min = 0.01, max = .99, value = .72, step=.01),
      div("For", tags$b("Dodecahedron"), "default value is 0.72",
          style = "font-size: 9.5pt;color:teal",align="left")
      ),

    br(),br(),

    sliderInput("pts",
      label = h5("Percentage of sequence:"),
      min = 10,
      max = 100,
      step = 10,
      value = 100),br(),

#    div(bsActionButton("gen", label = "Randomize"),align="right"),
    div(bsButton("gen", label = "Randomize"),align="right"),
        div("Click", tags$b("Randomize")," to re-randomize outcomes based on current settings.",
            style = "font-size: 9.5pt;color:teal",align="right"),br(),
           br(), br(), br(), br(),

        div("Shiny app by",
            a(href="http://statweb.calpoly.edu/jdoi/",target="_blank",
              "Jimmy Doi"),align="right", style = "font-size: 8pt"),

        div("Base R code by",
            a(href="http://statweb.calpoly.edu/jdoi/",target="_blank",
              "Jimmy Doi"),align="right", style = "font-size: 8pt"),

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

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

  # Show the generated 3d scatterplot
  mainPanel(
    rglwidgetOutput("sctPlot"),
  div(HTML("
"),
  p(tags$b("NOTE:"), "In the image above all points nearest a particular vertex/endpoint are shown in a common color.
Rotate the image by clicking your mouse within the plot and dragging the cursor. Also, use
    the scroll wheel of the mouse to zoom in/out of the image. Set the sequence percentage to 100%
            and slightly zoom out to improve image resolution.",align="center"),align="center"),br(),br(),
  p("For a better understanding of the chaos game, please",
     HTML("click here"),"to access the 2 dimensional version of the app. Use the animation in the 'Initial Sequence'
           plot to see a step-by-step progression of the game."
               ,align="center")
    )
) #fluidPage
) #shinyUI


base::library('Rtsne')
base::library('ggplot2')

DimensionalityReduction <- function () {
    pca.show <- function (data) {
        sdev2 <- pca.fit(data=data)$sdev ^ 2
        proportion <- base::cumsum(sdev2) / base::sum(sdev2)
        base::return(graphics::barplot(height=proportion))
    }

    pca.fit <- function (data) {
        base::is.data.frame(data) || base::stop()
        base::return(stats::princomp(data, cor=TRUE))
    }

    pca.transform <- function (model, data, number=3) {
        base::return(base::as.data.frame(
            stats::predict(model, data)[, 1:number]
        ))
    }

    pca.fit_transform <- function (data, number=3) {
        model <- pca.fit(data)
        base::return(pca.transform(model, data, number))
    }

    mic.show <- function (data, response) {
        model <- mic.fit(data, response)
        graphics::plot(base::abs(pearson)~mic, model, pch=21,  col=4, bg=5)
        graphics::text(model$mic, base::abs(model$pearson), labels=base::rownames(model))
    }

    mic.fit <- function (data, response) {
        M <- minerva::mine(data, y=response, alpha=0.7)
        model <- base::data.frame(
            mic=base::c(M$MIC), pearson=stats::cor(data, y=response, method='pearson')
        )
        base::rownames(model) <- base::colnames(data)
        base::return(model)
    }

    mic.transform <- function (model, data, number=3, method=c('mic', 'pearson')) {
        method <- base::match.arg(method)
        rank <- base::nrow(model) -
            base::rank(base::abs(model[method]), ties.method='first')
        model <- model[base::order(rank), ]
        base::return(data[base::rownames(model[1:number, ])])
    }

    mic.fit_transform <- function (data, response, number=3, method=c('mic', 'pearson')) {
        method <- base::match.arg(method)
        model <- mic.fit(data, response)
        base::return(mic.transform(model, data, number, method))
    }

    tsne.show <- function (data, response=NULL) {
        tsne <- tsne.fit_transform(data, 2)
        if (base::is.null(response)) {
            full <- base::data.frame(x=tsne[, 1], y=tsne[, 2])
            ggplot2::ggplot(full, ggplot2::aes(x, y)) + ggplot2::geom_point()
        } else {
            full <- base::data.frame(x=tsne[, 1], y=tsne[, 2], color=response)
            ggplot2::ggplot(full, ggplot2::aes(x, y)) + ggplot2::geom_point(
                ggplot2::aes(colour=color)
            ) + ggplot2::scale_colour_gradient(
                low='white', high='blue', guide='colorbar'
            )
        }
    }

    tsne.fit_transform <- function (data, number=3) {
        base::return(base::as.data.frame(Rtsne::Rtsne(data, dims=number)$Y))
    }

    self <- list(
        pca.show=pca.show, pca.fit=pca.fit, pca.transform=pca.transform, pca.fit_transform=pca.fit_transform,
        mic.show=mic.show, mic.fit=mic.fit, mic.transform=mic.transform, mic.fit_transform=mic.fit_transform,
        tsne.show=tsne.show, tsne.fit_transform=tsne.fit_transform
    )
    base::class(self) <- base::append(base::class(self), 'DimensionalityReduction')
    base::return(self)
}


# portfolio.r
#
# Functions for portfolio analysis
# last updated: September 25, 2016 by Ismael Jimenez
#
# Functions:
# 1. efficient.portfolio.risk    compute minimum variance portfolio
#                                subject to target risk

stopifnot("package:quadprog" %in% search()  ||  require("quadprog",quietly = TRUE) )
stopifnot("package:quantmod" %in% search()  ||  require("quantmod",quietly = TRUE) )

source("http://faculty.washington.edu/ezivot/econ424/portfolio_noshorts.r")

efficient.portfolio.risk <- function(er, cov.mat, target.risk, shorts=TRUE)
{
  incr <- 0.00001
  e.port <- globalMin.portfolio(er, cov.mat, shorts)
  currentEr <- as.numeric(e.port["er"])
  currentSd <- as.numeric(e.port["sd"])

  while(currentSd < target.risk) {
    currentEr <- currentEr+incr
    e.port <- efficient.portfolio(er, covmat, currentEr, shorts)
    currentEr <- as.numeric(e.port["er"])
    currentSd <- as.numeric(e.port["sd"])
  }
  e.port
}

getReturns.monthly = function(ticker, from = "1927-01-01") {
  ticker <- getSymbols(ticker, from = as.Date(from))
  MonthRet <- monthlyReturn(get(ticker))*100
  MonthRet
}


gm_mean = function(x, na.rm=TRUE){
  exp(sum(log(x[x > 0]), na.rm=na.rm) / length(x))
}


# Sum-product and beliefs update examples
A=matrix(c(.8,.2),2,1)
B=matrix(c(.6,.4,.3,.7),2,2)
C=matrix(c(.5,.5,.8,.8),2,2)
D=matrix(c(.3,.7,.4,.6),2,2)

Bs = t(A) %*% t(B)
Cs = Bs %*% t(C)
Ds = Cs %*% t(D)
Ds


#' Calculate numbers and statistics for table one
#'
#' @param main A character for the variable names of interests.
#' @param variable.id A numeric/integer vector indicating the variables to compare.
#' @param dataset A data.frame, the annotation data which table one will be generated from.
#' @return A data frame for table one visualization or export.
#' @examples
#' output <- tableone("Cancer", c(1:5), index) # Binary main variable
#' output <- tableone("Smoking", c(1:4, 6), index) # Categorical main variable
#' output <- tableone("RIN", c(2:6), index) # Continuous main variable
#'
#' @export
#'
tableone <- function(main, variable.id, dataset) {

	# Check for all inputs
	if(is.null(main) | is.null(variable.id) | is.null(dataset)) {
		stop("Missing one of the three inputs...")
	}

	# Check input formats
	if(class(main) != "character" | !class(variable.id) %in% c("numeric", "integer") | class(dataset) != "data.frame") {
		stop("Input format wrong...")
	}

	# Check dimensions and whether indexes are in the dataframe
	if(!main %in% names(dataset) | max(variable.id) > ncol(dataset)) {
		stop("Variables not found in the input dataset...")
	}

	# Check if the main variable of interests is numeric
	# If so, test association by other groups via t-test/anova/correlation
	if (is.numeric(dataset[,main])){
		out.table <- data.frame(Variable=character(), Statistics=character(), Pval=character(), stringsAsFactors=FALSE)
		for (i in variable.id) {
			if (is.numeric(dataset[,i])) {
				this.dat <- dataset[,c(main, names(dataset)[i])]
				this.res <- cor.test(this.dat[,1], this.dat[,2])
				this.out <- c(names(dataset)[i], as.character(round(this.res$estimate, digits=4)), as.character(round(this.res$p.value, digits=4)))
				out.table[nrow(out.table)+1, ] <-this.out
			} else {
				dataset[,i] <- as.factor(dataset[,i])
				this.dat <- dataset[,c(main, names(dataset)[i])]

				if ( length(levels(this.dat[,names(dataset)[i]])) == 2 ){
					this.res <- t.test(this.dat[,1] ~ this.dat[,2])
					this.out <- c(paste(names(dataset)[i], "; Ref=", levels(this.dat[,2])[1], sep=""),
								as.character(round(this.res$statistic, digits=4)), as.character(round(this.res$p.value, digits=4)))
					out.table[nrow(out.table)+1, ] <-this.out

				} else {
					this.res <- summary(aov(this.dat[,1] ~ this.dat[,2]))
					this.out <- c(names(dataset)[i], as.character(round(this.res[[1]][1,4], digits=4)), as.character(round(this.res[[1]][1,5], digits=4)))
					out.table[nrow(out.table)+1, ] <-this.out
				}
			}
			print(names(dataset[i]))
		}

	# If the main variable of interests is categorical
	} else {
		if(!is.factor(dataset[,main])) {dataset[,main] <- factor(dataset[,main])}

		# whether there are two levels in main variable of interests
		if( length(levels(dataset[,main])) == 2) {
			id <- which(names(dataset) == main)
			out.table <- matrix(nrow=0, ncol=(3+length(levels(dataset[,main]))))
			name_and_N <- paste(levels(dataset[,main]), " (N=", table(dataset[,main]), ")", sep="")
			colnames(out.table) <- c("Variable", name_and_N, "Statistics", "Pval")
			out.table <- as.data.frame(out.table)

			for (i in variable.id) {
				if (is.numeric(dataset[,i])) {
					this.dat <- dataset[,c(main, names(dataset)[i])]
					this.res <- t.test(this.dat[,2] ~ this.dat[,1])
					stat.table <- cbind(aggregate(this.dat[,2], list(this.dat[,1]), function(x) mean(x, na.rm=T)), aggregate(this.dat[,2], list(this.dat[,1]), function(x) sd(x, na.rm=T)))
					this.out <- c(names(dataset)[i],
								apply(stat.table, 1, function(x) paste(round(as.numeric(x[2]),digit=2), " (", round(as.numeric(x[4]),digit=2), ")", sep="")),
								as.character(round(this.res$statistic, digits=4)), as.character(round(this.res$p.value, digits=4)))
					out.table[nrow(out.table)+1, ] <- this.out
				} else {
					dataset[,i] <- as.factor(dataset[,i])
					this.dat <- dataset[,c(main, names(dataset)[i])]
					if ( length(levels(this.dat[,names(dataset)[i]])) == 2 ){
						this.res <- fisher.test(this.dat[,1], this.dat[,2])
						stat.table <- cbind(table(this.dat[,1], this.dat[,2]), prop.table(table(this.dat[,1], this.dat[,2]), 1))
						this.out <- c(paste(names(dataset)[i], "; Ref=", levels(this.dat[,2])[1], sep=""),
									apply(stat.table, 1, function(x) paste(round(as.numeric(x[1]),digit=2), " (", round(as.numeric(x[3]*100),digit=2), "%)", sep="")),
									as.character(round(this.res$estimate, digits=4)), as.character(round(this.res$p.value, digits=4)))
						out.table[nrow(out.table)+1, ] <-this.out
					} else {
						this.res <- chisq.test(this.dat[,1], this.dat[,2])
						a <- table(this.dat[,1], this.dat[,2])
						b <- prop.table(table(this.dat[,1], this.dat[,2]), 1)
						stat.table <- t(matrix(paste(a, " (", round(b*100, digits=2), "%)", sep=""), nrow=length(levels(this.dat[,1])), ncol=length(levels(this.dat[,2]))))
						stat.table <- cbind(levels(this.dat[,2]), stat.table)
						this.res <- c(paste(names(dataset)[i], "; Ref=", levels(this.dat[,2])[1], sep=""),
									rep(NA, length(levels(this.dat[,1]))),
									as.character(round(this.res$statistic, digits=4)), as.character(round(this.res$p.value, digits=4)))
						out.table[nrow(out.table)+1, ] <- this.res
						out.table[(nrow(out.table)+1):(nrow(out.table)+(length(levels(this.dat[,2])))), 1:(1+length(levels(this.dat[,1])))] <- stat.table
					}
				}
				print(names(dataset[i]))
			}

		# whether there are more than two levels in main variable of interests
		} else {
			id <- which(names(dataset) == main)
			out.table <- matrix(nrow=0, ncol=(3+length(levels(dataset[,main]))))
			name_and_N <- paste(levels(dataset[,main]), " (N=", table(dataset[,main]), ")", sep="")
			colnames(out.table) <- c("Variable", name_and_N, "Statistics", "Pval")
			out.table <- as.data.frame(out.table)

			for (i in variable.id) {
				if (is.numeric(dataset[,i])) {
					this.dat <- dataset[,c(main, names(dataset)[i])]
					this.res <- summary(aov(this.dat[,2] ~ this.dat[,1]))
					stat.table <- cbind(aggregate(this.dat[,2], list(this.dat[,1]), function(x) mean(x, na.rm=T)), aggregate(this.dat[,2], list(this.dat[,1]), function(x) sd(x, na.rm=T)))
					this.out <- c(names(dataset)[i],
								apply(stat.table, 1, function(x) paste(round(as.numeric(x[2]),digit=2), " (", round(as.numeric(x[4]),digit=2), ")", sep="")),
								as.character(round(this.res[[1]][1,4], digits=4)), as.character(round(this.res[[1]][1,5], digits=4)))
					out.table[nrow(out.table)+1, ] <- this.out
				} else {
					dataset[,i] <- as.factor(dataset[,i])
					this.dat <- dataset[,c(main, names(dataset)[i])]
					this.res <- chisq.test(this.dat[,1], this.dat[,2])
					a <- table(this.dat[,1], this.dat[,2])
					b <- prop.table(table(this.dat[,1], this.dat[,2]), 1)
					stat.table <- t(matrix(paste(a, " (", round(b*100, digits=2), "%)", sep=""), nrow=length(levels(this.dat[,1])), ncol=length(levels(this.dat[,2]))))
					stat.table <- cbind(levels(this.dat[,2]), stat.table)
					this.res <- c(paste(names(dataset)[i], "; Ref=", levels(this.dat[,2])[1], sep=""),
								rep(NA, length(levels(this.dat[,1]))),
								as.character(round(this.res$statistic, digits=4)), as.character(round(this.res$p.value, digits=4)))
					out.table[nrow(out.table)+1, ] <- this.res
					out.table[(nrow(out.table)+1):(nrow(out.table)+(length(levels(this.dat[,2])))), 1:(1+length(levels(this.dat[,1])))] <- stat.table
				}
				print(names(dataset[i]))
			}
		}
	}
	return(out.table)
}

#' Calculate numbers and statistics for table one
#'
#' @param g.obj A tableGrob object.
#' @param row row id.
#' @param col column id.
#' @param name default option
#' @return indexes of cells matching criteria.
#'
find_cell <- function(g.obj, row, col, name="core-fg"){
	l <- g.obj$layout
	ind <- lapply(row, function(x) which(l$t == (x+1) & l$l==col & l$name==name))
	return(ind)
}

#' Plot table one
#'
#' @param table.obj A output from the tableone() function.
#' @param p.threshold A numeric indicating significant value cutoff for bolding p-value.
#' @return A plot of table one.
#'
#' @import grid
#' @import gridExtra
#' @export
tableone.plot <- function(table.obj, p.threshold=0.05) {
	if(class(p.threshold) != "numeric") {
		stop("Please check the p-value threshold format...")
	}

	table.obj[is.na(table.obj)] <- ""
	row.id <- which(as.numeric(table.obj$Pval)<p.threshold)
	col <- ncol(table.obj) + 1

	x <- hj <- matrix(c(0.9, rep(0.5, (ncol(table.obj)-1))), ncol=(col-1), nrow=nrow(table.obj), byrow=TRUE)
	tt1 <- ttheme_default(core=list(fg_params=list(hjust = as.vector(hj), x = as.vector(x))))
	g.obj <- tableGrob(table.obj, , rows = NULL, theme=tt1)

	ind <- find_cell(g.obj, row.id, col=(col-1), "core-fg")

	for (i in ind) {
		g.obj$grobs[i][[1]][["gp"]] <- gpar(fontface="bold")
	}
	grid.draw(g.obj)
	grid.newpage()
}

#' Write table one to excel file
#'
#' @param table.obj A output from the tableone() function.
#' @param filename A character indicating the output name of the files. Default is table1.
#' @return A xlsx file of table one.
#'
#' @import xlsx
#' @export
tableone.export <- function(table.obj, filename="Table1") {
	if(class(filename) != "character") {
		stop("Invalid file name...")
	}

	outputname <- paste(filename, ".xlsx", sep="")

	write.xlsx(table.obj, outputname, row.names = FALSE, append = TRUE)
}


library(psych)

region_cells <- read.csv('../input_data/region_cells.csv')
subset <- region_cells[which(region_cells$density>0 & region_cells$density<30),]

biserial(region_cells$density, region_cells$hasstop) # 0.1756958
biserial(subset$density, subset$hasstop) # 0.4397582
# Outliers distort the correlation a lot!
# We only take a subset of the data, with which we get a correlation of 0.4397582
boxplot(density~hasstop, data=subset)


#' Plot high correlations among parameters
#'
#' Identify parameters with high correlation (as defined by user).
#' @param a1 list file produced by grab.aux.files function
#' @param correlation.limit will return parameter combos where |correlation| > value
#' @param save.plots save individual plots
#' @param od output directory for plots and csv files
#' @param plotf type of plot to save
#' @export

PlotHighCorr <- function(a1,correlation.limit,save.plots,od,plotf){

  par(mfrow=c(1,1) )
  npar <- a1$npar
  if (npar != -999){
    count.high.corr <- rep(0, npar)
    asap.cor.mat <- a1$asap.cor.mat[1:npar, 1:npar]
    text.col <- ifelse(abs(asap.cor.mat)>correlation.limit, "red", "white")
    tcor<-0
    for (i in 1:npar) {
      for (j in 1:npar) {
        if (text.col[i,j]=="red" && is.na(text.col[i,j])==F) tcor<- tcor+1
        if (text.col[i,j]=="red" && is.na(text.col[i,j])==F) count.high.corr[i]<- count.high.corr[i]+1
      } # end j-loop
    } # end i-loop

    plot(seq(1,npar), count.high.corr[1:npar], type='l', xlab="Parameter", lwd=1, col='black',
         ylab="Number of high correlations", ylim=c(0,1.1*max(count.high.corr, 1) )  )

    high.rows <- matrix(NA, 1, 2)
    cor.vals <- 0
    for (irow in 1:npar) {
      temp.row <- as.vector(which( abs(asap.cor.mat[irow,])>correlation.limit))

      if(length(temp.row)>0) {
        cor.pairs <- cbind(rep(irow, length(temp.row)), temp.row)
        high.rows<- rbind(high.rows, cor.pairs)
        cor.vals <-c(cor.vals, asap.cor.mat[irow, temp.row] )
      }
    } #end loop over irow

    high.rows<- high.rows[-1,]
    cor.vals <- cor.vals[-1]

    if (length(cor.vals) >0 ) {
      named.cor.pairs <- as.data.frame(matrix(NA, length(cor.vals),3))
      colnames(named.cor.pairs)=c("Par1", "Par2", "Correlation")
      if (length(cor.vals)==1) {
        named.cor.pairs[,1] <-a1$asap.cor.names[high.rows[1]]
        named.cor.pairs[,2] <-a1$asap.cor.names[high.rows[2]]
      }
      if (length(cor.vals)>1) {
        named.cor.pairs[,1] <-a1$asap.cor.names[high.rows[,1]]
        named.cor.pairs[,2] <-a1$asap.cor.names[high.rows[,2]]
      }
      named.cor.pairs[,3] <-  cor.vals

      asap.name <- a1$asap.name

      write.csv(named.cor.pairs, file=paste0(od, "High.Corr.Pars_",asap.name,".csv"), row.names=F)
    }  # end check for length(cor.vals)

    if (save.plots) savePlot(paste0(od, "Corr.Limit.Count.by.par.",plotf), type=plotf)

  } # end if npar check

  return()
}


distance_DYS <- function (x, method= "hellinger", p = 0.5){

  if(method=="topsoe.D"){

    return(D.Topsoe(x[1,], x[2,]))
  }

  if (method == "ord") {
    x_dif <- x[1,]-x[2,]
    acum <- 0
    aux <- 0
    for(i in 1:length(x_dif)){
      aux <- x_dif[i]+aux
      acum <- acum+aux
    }
    return(abs(acum))
  }

  return(as.numeric(distance(x, method = method, p=p)))

}


require(rms)

#Get a dataset/keep a few columns
load('boys.rda')   # originally from mice package
d <- boys[,c("age", "bmi", "reg")]
i <- with(d, is.na(bmi) | is.na(reg))
length(unique(d$age)); length(unique(d$age[! i]))

#sum(is.na(dat$age)) #0
####Models
##1) Complete case
#Set datadist
# dat_naomit <- na.omit(dat)
# dd <- datadist(dat_naomit)
# options(datadist = "dd")

dd <- datadist(d); options(datadist='dd')

#Run model
f <- orm(age ~ bmi + reg, data = d)

#Run a simple contrast
contrast(f, list(bmi = 20), list(bmi = 19))
summary(f, bmi=19:20, est.all=FALSE)

##2) Multiple imputation (default settings)

#Fit imputation model
# imp_mod <- mice(dat, m = 5) #Happens with ‘aregImpute’ as well
#Fit same orm model with imputed datasets
a <- aregImpute(~ age + bmi + reg, data=d, n.impute=5)

g <-
    fit.mult.impute(
        formula = age ~ bmi + reg,
        fitter = orm,
        xtrans = a,
        data = d
    )
dim(vcov(f, regcoef.only=TRUE))
dim(vcov(g, regcoef.only=TRUE))

summary(g, bmi=19:20, est.all=FALSE)

#Try the same contrast
contrast(g, list(bmi = 20), list(bmi = 19)) #Non-conformable dimension for matrix multiplication


# source: https://en.wikipedia.org/wiki/Sudoku
s=matrix(0,ncol=9,nrow=9)
s[1,c(1,2,5)]=c(5,3,7)
s[2,c(1,4,5,6)]=c(6,1,9,5)
s[3,c(2,3,8)]=c(9,8,6)
s[4,c(1,5,9)]=c(8,6,3)
s[5,c(1,4,6,9)]=c(4,8,3,1)
s[6,c(1,5,9)]=c(7,2,6)
s[7,c(2,7,8)]=c(6,2,8)
s[8,c(4,5,6,9)]=c(4,1,9,5)
s[9,c(5,8,9)]=c(8,7,9)


suppressMessages(library(stats))
suppressMessages(library(craze))

if (fml_mpi()){
  comm.set.seed(1234)
} else {
  set.seed(1234)
}

n = 5
x = crossprod(matrix(runif(n*n), n))
y = matrix(1.0:5.0, n, 1)
x_fml = fmlmat(x)

e_test = eigen(x_fml)
e_truth = eigen(x)

test = as.matrix(e_test$values)
truth = e_truth$values
stopifnot(all.equal(test, truth))

test = as.matrix(e_test$vectors)
truth = e_truth$vectors
stopifnot(all.equal(abs(test), abs(truth)))


#' p_atm_z
#'
#' Calculate local air ressure as function of elevation/altitude in meters and sea-level pressure.
#'
#' @param z       numeric elevation/altitude (m).
#' @param p_sl    numeric pressure at sea level, per weather report (hPa),Default 101235 Pa.
#'
#' @author Istituto per la Bioeconomia CNR Firenze Italy  Alfonso Crisci \email{alfonso.crisci@@ibe.cnr.it}
#' @references    2005 ASHRAE Handbook - Fundamentals (SI) ch.6 (3)
#' @return        numeric pressure (Pa)
#' @export
#'

p_atm_z <- function(z, p_sl = 1013.25) {
                    p_sl * (1 - 2.25577e-5 * z)^5.2559
}


# Euler1 in R

euler1 <- function(size) {
    result <- 0
    for (x in 1:size) {
        if (x %% 3 == 0 || x %% 5 == 0)
            result <- result + x
    }
    result
}

euler1(999)


devtools::load_all()
library(parallel)
library(quantregGrowth)
library(quantreg)
RNGkind("L'Ecuyer-CMRG")
set.seed(999983)

ncores <- 4
n <- 400
m <- 20
lengthout <- 1024
v_taus <- seq(0.001, 0.999, length.out = lengthout)
k1 <- 11; ktau <- 2; m1 <- 4; mtau <- 3
v_k <- c(ktau, k1); v_m <- c(mtau, m1); v_dim <- v_k + v_m

# compare functions(increasing in x & no constraint)
optim_code <- function(m = 20, taus = v_taus, ...) {
    # L2 loss
    L2loss <- matrix(rep(0, length(taus) * 5), nrow = 5)
    colnames(L2loss) <- taus
    rownames(L2loss) <- c("bfgs", "optim",
                        "nlm", "nlm.fd",  "efs")
    # time
    m_time <- matrix(rep(0, 3 * 5), nrow = 5)
    rownames(m_time) <- rownames(L2loss)
    for (j in seq(m)) {
        #train
        x <- runif(n); ord <- order(x)
        x <- x[ord]
        y <- obs_f(x, ...)
        # test
        test_x <- seq(min(x), max(x), length.out = 1e4)
        # bfgs
        m_time[1, ] <- m_time[1, ] + system.time(bfgs_fit <- qs_scam(x, y,
                    maxit = 20, ntaus = 10,
                    arg_bs = c("tesmi1", "cr"),
                    opt = "bfgs", dims = v_dim, tol = 1e-2))[1:3]
        # optim
        m_time[2, ] <- m_time[2, ] + system.time(optim_fit <- qs_scam(x, y,
                    maxit = 20, ntaus = 10,
                    arg_bs = c("tesmi1", "cr"),
                    opt = "optim", dims = v_dim, tol = 1e-2))[1:3]
        # nlm
        m_time[3, ] <- m_time[3, ] + system.time(nlm_fit <- qs_scam(x, y,
                    maxit = 20, ntaus = 10,
                    arg_bs = c("tesmi1", "cr"),
                    opt = "nlm", dims = v_dim, tol = 1e-2))[1:3]
        # nlm.fd
        m_time[4, ] <- m_time[4, ] + system.time(nlmfd_fit <- qs_scam(x, y,
                    maxit = 20, ntaus = 10,
                    arg_bs = c("tesmi1", "cr"),
                    opt = "nlm.fd", dims = v_dim, tol = 1e-2))[1:3]
        # efs
        m_time[5, ] <- m_time[5, ] + system.time(efs_fit <- qs_scam(x, y,
                    maxit = 20, ntaus = 10,
                    arg_bs = c("tesmi1", "cr"),
                    opt = "efs", dims = v_dim, tol = 1e-2))[1:3]
        for (i in seq_along(taus)) {
            tau <- taus[i]
            truth <- truth_f(test_x, tau, ...)
            L2loss[1, i] <- L2loss[1, i] + mean((c(predict(bfgs_fit, data.frame(tau = tau, x1 = test_x))) - truth)^2)
            L2loss[2, i] <- L2loss[2, i] + mean((c(predict(optim_fit, data.frame(tau = tau, x1 = test_x))) - truth)^2)
            L2loss[3, i] <- L2loss[3, i] + mean((c(predict(nlm_fit, data.frame(tau = tau, x1 = test_x))) - truth)^2)
            L2loss[4, i] <- L2loss[4, i] + mean((c(predict(nlmfd_fit, data.frame(tau = tau, x1 = test_x))) - truth)^2)
            L2loss[5, i] <- L2loss[5, i] + mean((c(predict(efs_fit, data.frame(tau = tau, x1 = test_x))) - truth)^2)
        }
    }

    list(L2loss = L2loss / m,
        time = m_time / m,
        model = list(bfgs_fit, optim_fit,
        nlm_fit, nlmfd_fit, efs_fit))
}
# comp <- optim_code(1, gmean = "linear", xsig = "linear", derr = "t3")
# comp <- compare_no(1, gmean = "sqrtsin", xsig = "quad", derr = "chisq3")

v_gmean <- c("linear", "log", "sin", "lsin", "sqrtsin")
v_xsig <- c("const", "linear", "quad")
v_derr <- c("norm", "chisq3", "t3", "t1")

opt <- mclapply(v_gmean, gmean_loop <- function(gmean) {
    mclapply(v_xsig, xsig_loop <- function(xsig) {
        mclapply(v_derr, derr_loop <- function(derr) {
            optim_code(m, gmean = gmean, xsig = xsig, derr = derr)
        }, mc.cores = ncores)
    }, mc.cores = ncores)
}, mc.cores = ncores)

save(opt, file = "sim_opt.RData")


# From Tamas Ferenci

require(rms)
set.seed(1)
n <- 100
SimData <- data.frame( x1 = sample(c(-1,0,1), n, TRUE),
            x2 = sample(c(-1,0,1), n, TRUE),
            exposure = rlnorm(100) )
SimData$y <- round(runif(n), 2)
dd <- datadist(SimData)
options(datadist="dd")
f <- lrm(y ~ x1 + x2 + offset(log(exposure)), data=SimData, eps=.0001)
d <- orm(y ~ x1 + x2 + offset(log(exposure)), data=SimData, eps=.0001)
max(abs(coef(f) - coef(d)))

h <- orm(y ~ x1 + x2, family='cloglog', data=SimData)
k <- orm(y ~ x1 + x2 + offset( log( exposure ) ),
         family='cloglog', data=SimData)
coef(h) - coef(k)


# Basic proof of concept to show how the correlation structure is preserved using NMF.
library(devtools)

taq_file = "~/projects/jackson_lecture/may_trades/taq_20100506_trades_all.csv"

#document("..")
library(nxcore)

data(sp)
symbols = sp$symbol[sample(1:length(sp$symbol), 20)]
x = read_taq(taq_file, symbols, on="minutes", k=1)
ci1 = coint_measure(x, minutes(30))

x_mat = as.matrix(x)
plot(x_mat[,1], type='l', ylim=range(x_mat))
for (i in 2:ncol(x_mat))
  lines(x_mat[,i], col=i)

dev.new()

nmf_fit = nmf(x_mat, rank=7)
W = nmf_fit@fit@W
H = nmf_fit@fit@H

x_proj = tcrossprod(x_mat, H)
x_proj_ts = xts(x_proj, order.by=time(x))
ci2 = coint_measure(x_proj_ts, minutes(30))

plot(x_proj[,1], type='l', ylim=range(x_proj))
for (i in 2:ncol(x_proj))
  lines(x_proj[,i], col=i)

svd_fit = svd(x_mat)
x_proj2 = x_mat %*% svd_fit$v[,1:7]
x_proj_ts2 = xts(x_proj2, order.by=time(x))
ci3 = coint_measure(x_proj_ts2, minutes(30))

# Now call the NMF and SVD "online".

ci22 = coint_measure(x, minutes(30), dr="nmf", dr_rank=7)

ci32 = coint_measure(x, minutes(30), dr="svd", dr_rank=7)

plot(ci1, ylim=range(ci1, ci2, ci3))
lines(ci2, col="red")
lines(ci3, col="blue")
lines(ci22, col="green")
lines(ci32, col="grey")

dev.new()
dm = cbind(ci2-ci1, ci3-ci1, ci22-ci1, ci32-ci1)
plot(dm[,1], ylim=range(dm), color="red")
lines(dm[,2], col="blue")
lines(dm[,3], col="green")
lines(dm[,4], col="grey")

#library(doMC); registerDoMC(3)
nmf_meas = foreach(i=2:10, .combine=rbind) %do% {
  ci_nmf = coint_measure(x, minutes(30), dr="nmf", dr_rank=i)
  c(mean(as.vector(ci_nmf)-ci1), var(ci_nmf-ci1))
}

svd_meas = foreach(i=2:10, .combine=rbind) %do% {
  ci_svd = coint_measure(x, minutes(30), dr="svd", dr_rank=i)
  c(mean(as.vector(ci_svd)-ci1), var(ci_svd-ci1))
}

# NMF wins both for bias and variance.
plot(nmf_meas[,1], type="l", ylim=range(c(svd_meas[,1], nmf_meas[,1])))
lines(svd_meas[,1], col="red")
dev.new()
plot(nmf_meas[,2], type="l", ylim=range(c(svd_meas[,2], nmf_meas[,2])))
lines(svd_meas[,2], col="red")

nmf_meas = foreach(i=2:20, .combine=rbind) %do% {
  print(
    system.time({ci_nmf = coint_measure(x, minutes(30), dr="nmf", dr_rank=i)}))
  print(i)
  c(mean(as.vector(ci_nmf)-ci1), var(ci_nmf-ci1))
}

# Let's try all of them.
#registerDoMC(3)
x = read_taq(taq_file, sp$symbol, on="minutes", k=1)
nmf_meas_sp = foreach(i=2:15, .combine=rbind) %do% {
  print(
    system.time({ci_nmf = coint_measure(x, minutes(30), dr="nmf", dr_rank=i)}))
  print(i)
  c(mean(as.vector(ci_nmf)-ci1), var(ci_nmf-ci1))
}


#!/usr/bin/Rscript

# Bhishan Poudel
# Jan 16, 2016

# set up a device driver to plot
#postscript(file='~/Copy/Programming/R/rprograms/plotting/legends/legend2.eps')

par(mar = c(4, 4, 2, 0.1))
x_mean <- 1.5
x_sd <- 1.2
hist( rnorm(100, x_mean, x_sd),
      main = substitute( paste(X[i], " ~ N(", mu, "=", m, ", ", sigma^2, "=", s2, ")"),
                         list(m = x_mean, s2 = x_sd^2)))

# turn off device driver
#dev.off()


m = 10000
a = 5
b = 3

beta = rbeta(m, shape1=a, shape2=b)

success = beta/(1-beta)

mean(beta/(1-beta))

ind = success > 1

mean(ind)

m = 100000
a = 0
b = 1
norm = rnorm(m,a,b)

qnorm(0.3,mean=a,sd=b)

quantile(norm, prob=0.3)


lp = function(trainingset, testset, column, upperBound = 1e16){

    matrixA = subset(trainingset, select = column)
    effort = trainingset$Effort
    nV = length(column)

    nConstrains = 2*length(column) + 4*dim(trainingset)[1]
    nVar = length(column) + 2*dim(trainingset)[1]
    mat1 = matrix(NA, ncol = nVar, nrow = dim(trainingset)[1])
    mat2 = matrix(NA, ncol = nVar, nrow = dim(trainingset)[1])
    mat3 = matrix(NA, ncol = nVar, nrow = dim(trainingset)[1])
    mat4 = matrix(0, ncol = nVar, nrow = nV)
    mat5 = matrix(0, ncol = nVar, nrow = nV)
    mat6 = matrix(0, ncol = nVar, nrow = dim(trainingset)[1])

    tzip = (1:dim(mat1)[1]*2+nV-1)
    cVec = rep(0, nVar)
    cVec[tzip] = 1
    for(i in 1:dim(matrixA)[1]){
      for(j in 1:dim(matrixA)[2]){
        mat1[i,j] = matrixA[i,j]
      }
    }
    mat1[is.na(mat1)] = 0
    b1 = rep(0, dim(mat1)[1])
    mat2 = mat1

    tzip= cbind((1:dim(mat2)[1]), (1:dim(mat2)[1]*2+nV-1))
    mat2[tzip] = -1
    effzip= cbind((1:dim(mat2)[1]), (1:dim(mat2)[1]*2+nV))
    mat2[effzip] = -1
    b2 = rep(0, dim(mat2)[1])

    mat3 = mat2
    tzip= cbind((1:dim(mat3)[1]), (1:dim(mat3)[1]*2+nV-1))
    mat3[tzip] = 1
    b3 = rep(0, dim(mat3)[1])

    diag(mat4) = 1
    b4 = rep(0, dim(mat4)[1])
    diag(mat5) = 1

    b5 = rep(upperBound, dim(mat5)[1])
    effzip= cbind((1:dim(mat6)[1]), (1:dim(mat6)[1]*2+nV))
    mat6[effzip] = 1
    b6 = effort
    A = rbind(mat1,mat2,mat3,mat4,mat5,mat6)
    constr = c(rep(">", dim(mat1)[1]), rep("<=", dim(mat2)[1]), rep(">=", dim(mat3)[1]), rep(">=", dim(mat4)[1]), rep("<=", dim(mat5)[1]), rep("=", dim(mat6)[1]))
    B = c(b1,b2,b3,b4,b5,b6)
    solSimplex = solveLP(cVec, B, A, const.dir = constr,lpSolve = TRUE, zero = 1e-16, tol = 1E-3)
    variablesValue = solSimplex$solution[1:nV]
    matrixATest = subset(testset, select = column)
    measured = testset$Effort

    prediction = rowSums(sweep(matrixATest, MARGIN = 2, variablesValue, `*`))

    return(list(data.frame(prediction,measured), variablesValue))
}


corr2 <- function(directory, threshold = 0) {
	corr <- numeric(0)

	for (i in 1:332) {
		data <- na.omit(read.csv(paste(directory, '/', sprintf("%03d", i), ".csv", sep="")))

		if (nrow(data) >= threshold) {
			cr <- cor(data["sulfate"], data["nitrate"])

			if (!is.na(cr)) {
				corr <- append(corr, cr)
			}
		}
	}

	corr
}


#'@name thin.env
#'@author Dr. Wilson Frantine-Silva
#'@description return spatially thinned dataset based on PCA coordinations
#'input and a minimum threshold of euclidian distances
#'@param rec.df.orig a PCA dataframe
#'@param thin.par a minimum distance threshold to keep samples apart each other
#'@param reps a number of replications. Each replication saves an random optimum
#'dataset of points at least as distant as distant or more as thin.par
#'

require("spThin")

thin.env<-function (rec.df.orig, thin.par, reps)
{
  reduced.rec.dfs <- vector("list", reps)
  #aqui modificamos o código original para uma função de distância euclidiana
  DistMat.save <- as.matrix(dist(rec.df.orig, method = "euclidian")) < thin.par
  diag(DistMat.save) <- FALSE
  DistMat.save[is.na(DistMat.save)] <- FALSE

  SumVec.save <- rowSums(DistMat.save)
  df.keep.save <- rep(TRUE, length(SumVec.save))
  for (Rep in seq_len(reps)) {
    DistMat <- DistMat.save
    SumVec <- SumVec.save
    df.keep <- df.keep.save
    while (any(DistMat) && sum(df.keep) > 1) {
      RemoveRec <- which(SumVec == max(SumVec))
      if (length(RemoveRec) > 1) {
        RemoveRec <- sample(RemoveRec, 1)
      }
      SumVec <- SumVec - DistMat[, RemoveRec]
      SumVec[RemoveRec] <- 0L
      DistMat[RemoveRec, ] <- FALSE
      DistMat[, RemoveRec] <- FALSE
      df.keep[RemoveRec] <- FALSE
    }
    rec.df <- rec.df.orig[df.keep, , drop = FALSE]
    #colnames(rec.df) <- c("Longitude", "Latitude")
    reduced.rec.dfs[[Rep]] <- rec.df
  }
  reduced.rec.order <- unlist(lapply(reduced.rec.dfs, nrow))
  reduced.rec.order <- order(reduced.rec.order, decreasing = TRUE)
  reduced.rec.dfs <- reduced.rec.dfs[reduced.rec.order]
  return(reduced.rec.dfs)
}


score <- function(input) {
    return((((((((((((((36.367080746577244) + ((input[1]) * (-0.10861311354908008))) + ((input[2]) * (0.046461486329936456))) + ((input[3]) * (0.027432259970172148))) + ((input[4]) * (2.6160671309537777))) + ((input[5]) * (-17.51793656329737))) + ((input[6]) * (3.7674418196772255))) + ((input[7]) * (-0.000021581753164971046))) + ((input[8]) * (-1.4711768622633645))) + ((input[9]) * (0.2956767140062958))) + ((input[10]) * (-0.012233831527259383))) + ((input[11]) * (-0.9220356453705304))) + ((input[12]) * (0.009038220462695552))) + ((input[13]) * (-0.542583033714222)))
}


gltpls <- function(oph=.3, cph=.2, t0=0.01, fs=16000) {
  npc <- round(t0 * fs, 0)
  itp <- round(oph * npc, 0)
  itn <- round(cph * npc, 0)
  itz <- npc - (itp + itn)
  rato <- seq(1, itp) / itp
  ratc <- seq(1, itn) / itn
#  gx <- c(3*rato^2 - 2*rato^3, 1 - ratc^2, rep(0, itz))
  gx <- c(.5 - .5*cos(pi*rato), .5 + .5*cos(pi*ratc), rep(0, itz))
  gx
}

gltplsd <- function(oph=.3, cph=.2, t0=0.01, fs=16000) {
  gx <- gltpls(oph, cph, t0, fs)
  n <- length(gx)
  gx <- c(gx[2:n] - gx[1:(n-1)], 0)
  gx
}


# percentile of normal distribution using r
# we will use qnorm function
# 10 th percentile of Normal distribution Mean = 70 and SD=13
qnorm(0.10,70,13)


nterms = as.integer(readline(prompt="How many terms should I print? "))
n1 = 0
n2 = 1
count = 2
if(nterms <= 0) {
print("Plese enter a positive integer")
} else {
if(nterms == 1) {
print("Fibonacci sequence:")
print(n1)
} else {
print("Fibonacci sequence:")
print(n1)
print(n2)
while(count < nterms) {
nth = n1 + n2
print(nth)
n1 = n2
n2 = nth
count = count + 1
}
}
}


## Dati

rigasopra <- c(-2.22, -0.53, 0.81)
rigaverticale <- c(-4.1, -1.46, -0.16)

prob <- c(7,4,5,
                 8,3,9,
                 6,2,1)

library(MASS)

k <- fractions(1/sum(prob))
marginale_x <-c((prob[1]+prob[2]+prob[3])*k,
                (prob[4]+prob[5]+prob[6])*k,
                (prob[7]+prob[8]+prob[9])*k)

marginale_y <-c((prob[1]+prob[4]+prob[7])*k,
                (prob[2]+prob[5]+prob[8])*k,
                (prob[3]+prob[6]+prob[9])*k)

atteso_x <- sum(marginale_x *rigaverticale)

varianza_y <- sum(marginale_y * (rigasopra)^2) - sum(marginale_y * (rigasopra))^2

print(k)
print(marginale_x)
print(marginale_y)
print(atteso_x)
print(varianza_y)


#dyn.load("./dev/tlpreg")
dyn.load("./tlpreg")

lasso0 <- function(y, X, b.init=NULL, lambda=NULL, pen.fac=rep(1,p), tol=1e-4, cd.maxit=1e+4) {

    n <- as.integer(nrow(X))
    p <- as.integer(ncol(X))
    xtx <- colSums(X*X)

    b0 <- mean(y)
    r <- y - b0
    if(is.null(lambda)) {
        lambda.max <- max(abs(crossprod(X, r)))/n
        lambda <- exp(seq(from=log(lambda.max),
                          to=log(ifelse(p < n, 1e-4, .01)*lambda.max),
                          length.out=100))
    }
    nlambda <- as.integer(length(lambda))

    if(is.null(b.init)) {
        b <- matrix(0, p, nlambda)
    } else {
        r <- r - X %*% b.init
        b <- matrix(b.init, p, nlambda)
    }

    pen.fac <- as.integer(pen.fac)

    .Call('lasso', X, b0, b, r, xtx, n, p, lambda, nlambda, pen.fac, tol, as.integer(cd.maxit))

    list(b = b, b0 = b0, lambda = lambda)
}

# b0 should be a vec: length(b0) == length(lambda)


rm(list = ls()) # clear console

# ADETAYO ADEGOKE
# WEEK 01 Homework - Logic, using Boolean Algebra and Finite Fields
# Due: February 05, 2020
# Mathematics E-23c, Spring 2020

# Questions 1 (a), (b) and (c)

# (p & q) IMPLIES (r | s) is equivalent to [not(p & q) | (r | s)]
# the le column represents this logical expression
eg <- expand.grid(c(TRUE, FALSE), c(TRUE, FALSE), c(TRUE, FALSE), c(TRUE, FALSE)); eg
ttbl <- data.frame(eg[,c(4:1)]); ttbl # reverse the columns
colnames(ttbl) <- c('p', 'q', 'r', 's'); ttbl #change the column names to match variable names, and display the truth table

# Had trouble with attach :(
# Construct the columns that will be used to compute the logical expression
ttbl$pq <- (ttbl$p & ttbl$q)
ttbl$notpq <- (!(ttbl$p & ttbl$q))
ttbl$rors <- (ttbl$r | ttbl$s)
ttbl$le <- (ttbl$notpq | ttbl$rors); ttbl # logical expression column

# The constructive normal form (aka cnf column below)for the LE looking at the truth table is
# (!p | !q | r | s)
ttbl$cnf <- (!(ttbl$p) | !(ttbl$q) | ttbl$r | ttbl$s); ttbl # voila, column le and cnf match in the truth table!

rm(list = ls()) # clear console

# Questions 2(a)

# setwd("/Users/adegade/OneDrive/Documents/Education/Harvard/Software Engineering/Spring-2020-MATH-E-23C/Homework")
Gssl <- read.csv("GSSLogical.csv") # load the input file
head(Gssl) # test that it and review columns
attach(Gssl)
index <- which(!is.na(Male) & !is.na(Republican) & !is.na(GunOwner) &
                 (Male == "FALSE") & (Republican == "FALSE") & (GunOwner == "TRUE")); index
length(index) # 37 = number of participants in the survey who were female democrats who owned guns

# Clean Up!
detach(Gssl)
rm(list = ls()) # clear console

# Questions 2(b)

# setwd("/Users/adegade/OneDrive/Documents/Education/Harvard/Software Engineering/Spring-2020-MATH-E-23C/Homework")
Redsox <- read.csv("RedSox2013.csv") # load the input file
head(Redsox) # test that it and review columns
attach(Redsox)
TRuns <- R + RA # create a new column that totals up runs
HRuns <- subset(Redsox, TRuns >= 10); HRuns # get a subset of data with for games with 10 runs or more
min(HRuns$Duration)

# Question 2(c)

boxplot(R ~ DayNight) # display box plot of runs in day and night Red Sox games

# Question 2(d)

tbl <- table(WonLost, Away); tbl # create the table for observed WonLost and Away comparison
Expected <- outer(rowSums(tbl), colSums(tbl))/sum(tbl); Expected # create the table for expected WonLost and Away comparison
chisq.test(tbl, Expected) # there is a 16.73% chance that the discreptancy b/w expected and observed comparison between WonLost and Away
# is not statistically relevant, assuming the null hypothesis of independence.  The dataset does not provide enough evidence to support
#  the null hypothesis of independence (0.1673 > 0.05).  Red Sox did not seem to have an advantage in Home or Away games.

tbl <- table(WonLost, DayNight); tbl # create the table for observed WonLost and Away comparison
Expected <- outer(rowSums(tbl), colSums(tbl))/sum(tbl); Expected # create the table for expected WonLost and Away comparison
chisq.test(tbl, Expected) # there is a 43.8% chance that the discreptancy b/w expected and observed comparison between WonLost and DayNight
# is not statistically relevant, assuming the null hypothesis of independence.  The dataset does not provide enough evidence to support
#  the null hypothesis of independence (0.438 > 0.05).  Red Sox did not seem to have an advantage in Home or Away games.

# Clean Up!
detach(Redsox)
rm(list = ls()) # clear console

# Question 3(a)

attach(airquality) # attach the data frame
head(airquality) # display the first few rows of the data frame
boxplot(Ozone ~ Month) # display box plot of how Ozone depends on Month
boxplot(Solar.R ~ Month) # display box plot of how Solar Radiation depends on Month
boxplot(Wind ~ Month) # display box plot of how Wind depends on Month
boxplot(Temp ~ Month) # display box plot of how Temperature depends on Month

# Question 3(b)

aq <- get("airquality"); head(airquality) # get and display the airquality data frame
attach(aq)

plot(Temp, Solar.R) # create a plot of Temperature versus Solar Radiation
model <- lm(Solar.R ~ Temp) # create a Model
abline(model$coefficients[1], model$coefficients[2]) # draw the regression line on the plot
# data points in the plot are widely dispersed, as such temperature does not seem to be good predictor for solar radiation

plot(Temp, Ozone) # create a plot of Temperature versus Ozone
model <- lm(Ozone ~ Temp) # create a Model
abline(model$coefficients[1], model$coefficients[2]) # draw the regression line on the plot
# data points in the plot are relatively close together with a strong positive linear relationship, as such temperature
# does seem to be good predictor for solar radiation

# Question 3(c)

# Define new logical vectors while accounting for the NA data points in the set
smoggy <- Ozone > mean(Ozone, na.rm = TRUE); head(smoggy)
windy <- Wind> mean(Wind, na.rm = TRUE); head(windy)
sunny <- Solar.R > mean(Solar.R, na.rm = TRUE); head(sunny)
hot <- Temp > mean(Temp, na.rm = TRUE); head(hot)

# Select the days where all four logical vectors defined above are true
subset(airquality, (smoggy == TRUE) & (windy == TRUE) & (sunny == TRUE) & (hot == TRUE))

# Question 3(d)

chisq.test(smoggy, windy) # there is a 4.29 x 10^(-4)% chance that observed dependencies between the two factors being compared
# happened by chance.  Since this is a lot less than 5%, we will reject the null hypothesis of independence between the
# two variables and propose that they are both probably dependent
# smoggy and windy are probably dependent variables

chisq.test(windy, sunny) # there is a 68.23% chance that observed dependencies between the two factors being compared
# happened by chance.  Since this is a lot more than 5%, we will fail to reject the null hypothesis of independence between the
# two variables and propose that they are both probably independent
# windy and sunny are probably independent variables

#Clean Up!
detach(airquality)
rm(list = ls()) # clear console


# test statistic
t=.26528/.10127
print(t)
df=17
t1value=qt(1-0.01,df)
t2value=qt(1-0.005,df)
print(t1value)
print(t2value)
  #  Thus, H0 would be rejected at the alpha= .01 level but not at the alpha=  .005 level
pvalue =pt(-t, df)
print(pvalue)


change.base <- function(n, base)
{
  ret <- integer(as.integer(logb(x=n, base=base))+1L)

  for (i in 1:length(ret))
  {
    ret[i] <- n %% base
    n <- n %/% base

  }

  return(ret)
}

sum.digits <- function(n, base=10)
{
  if (base < 2)
    stop("base must be at least 2")

  return(sum(change.base(n=n, base=base)))
}

sum.digits(1)
sum.digits(12345)
sum.digits(123045)
sum.digits(0xfe, 16)
sum.digits(0xf0e, 16)


library(combinat)

permute.me <- c("A", "B", "C", "D")
perms  <- permn(permute.me)  # list of all permutations
perms2 <- matrix(unlist(perms), ncol=length(permute.me), byrow=T)  # matrix of all permutations
perms3 <- apply(perms2, 1, paste, collapse="")  # vector of all permutations

incomplete <- c("ABCD", "CABD", "ACDB", "DACB", "BCDA", "ACBD", "ADCB", "CDAB",
                "DABC", "BCAD", "CADB", "CDBA", "CBAD", "ABDC", "ADBC", "BDCA",
                "DCBA", "BACD", "BADC", "BDAC", "CBDA", "DBCA", "DCAB")

setdiff(perms3, incomplete)


library("e1071")
head(iris,10)

x<-subset(iris,select = -Species)
print(x)
y<-c(iris$Species)
print(y)

svm = svm(x,y)
print(summary(svm))

pred = predict(svm,subset(iris,select= -Species))
print(table(pred,Species))


# Exploring ggplot2
library(ggplot2)

# A scatter plot has been made for you
ggplot(mtcars, aes(x = wt, y = mpg)) +
  geom_point()

# color
ggplot(mtcars, aes(x = wt, y = mpg, color = disp)) +
  geom_point()

# size
ggplot(mtcars, aes(x = wt, y = mpg, size = disp)) +
  geom_point()

# geom_point ------------------------------------------------------------------
	p <- ggplot(mtcars, aes(wt, mpg))
	p + geom_point()

	# Add aesthetic mappings
	p + geom_point(aes(colour = factor(cyl)))
	p + geom_point(aes(shape = factor(cyl)))
	p + geom_point(aes(size = qsec))

	# Change scales
	p + geom_point(aes(colour = cyl)) + scale_colour_gradient(low = "blue")
	p + geom_point(aes(shape = factor(cyl))) + scale_shape(solid = FALSE)

	# Set aesthetics to fixed value
	ggplot(mtcars, aes(wt, mpg)) + geom_point(colour = "red", size = 3)

	# Varying alpha is useful for large datasets
	d <- ggplot(diamonds, aes(carat, price))
	d + geom_point(alpha = 1/10)
	d + geom_point(alpha = 1/20)
	d + geom_point(alpha = 1/100)

	# For shapes that have a border (like 21), you can colour the inside and
	# outside separately. Use the stroke aesthetic to modify the width of the
	# border
	ggplot(mtcars, aes(wt, mpg)) +
	  geom_point(shape = 21, colour = "black", fill = "white", size = 5, stroke = 5)

	# You can create interesting shapes by layering multiple points of
	# different sizes
	p <- ggplot(mtcars, aes(mpg, wt, shape = factor(cyl)))
	p + geom_point(aes(colour = factor(cyl)), size = 4) +
	  geom_point(colour = "grey90", size = 1.5)
	p + geom_point(colour = "black", size = 4.5) +
	  geom_point(colour = "pink", size = 4) +
	  geom_point(aes(shape = factor(cyl)))

	# These extra layers don't usually appear in the legend, but we can
	# force their inclusion
	p + geom_point(colour = "black", size = 4.5, show.legend = TRUE) +
	  geom_point(colour = "pink", size = 4, show.legend = TRUE) +
	  geom_point(aes(shape = factor(cyl)))

	# geom_point warns when missing values have been dropped from the data set
	# and not plotted, you can turn this off by setting na.rm = TRUE
	mtcars2 <- transform(mtcars, mpg = ifelse(runif(32) < 0.2, NA, mpg))
	ggplot(mtcars2, aes(wt, mpg)) + geom_point()
	ggplot(mtcars2, aes(wt, mpg)) + geom_point(na.rm = TRUE)

# geom_point and geom_smooth --------------------------------------------------
# Explore the diamonds data frame with str()
str(diamonds)

# Add geom_point() with +
ggplot(diamonds, aes(x = carat, y = price)) + geom_point()

# Add geom_point() and geom_smooth() with +
ggplot(diamonds, aes(x = carat, y = price)) + geom_point() +
geom_smooth(method = "gam", span = 0.3)

# geom_point(alpha = 0.05) --------------------------------------------------

# 1 - The plot you created in the previous exercise
ggplot(diamonds, aes(x = carat, y = price)) +
  geom_point() +
  geom_smooth()

# 2 - Copy the above command but show only the smooth line
ggplot(diamonds, aes(x = carat, y = price)) +
  geom_smooth()

# 3 - Copy the above command and assign the correct value to col in aes()
ggplot(diamonds, aes(x = carat, y = price, color = clarity)) +
  geom_smooth()

# 4 - Keep the color settings from previous command. Plot only the points with argument alpha.
ggplot(diamonds, aes(x = carat, y = price, color = clarity)) + geom_point(alpha = 0.4)

# Object manipulation --------------------------------------------------
# Create the object containing the data and aes layers: dia_plot
dia_plot <- ggplot(diamonds, aes(x = carat, y = price))

# Add a geom layer with + and geom_point()
dia_plot <- dia_plot + geom_point()

# Add the same geom layer, but with aes() inside
dia_plot <- dia_plot + geom_point(aes(color = clarity))

dia_plot

# Understanding the grammar ------------------------------------------------
# 1 - The dia_plot object has been created for you
dia_plot <- ggplot(diamonds, aes(x = carat, y = price))

# 2 - Expand dia_plot by adding geom_point() with alpha set to 0.2
dia_plot <- dia_plot + geom_point(alpha = 0.2)

# 3 - Plot dia_plot with additional geom_smooth() with se set to FALSE
dia_plot + geom_smooth(se = FALSE)

# 4 - Copy the command from above and add aes() with the correct mapping to geom_smooth()
dia_plot + geom_smooth(aes(col = clarity), se = FALSE)

# xxxxxxxxxxxxxxxxxxxxxxx --------------------------------------------------
# xxxxxxxxxxxxxxxxxxxxxxx --------------------------------------------------
# xxxxxxxxxxxxxxxxxxxxxxx --------------------------------------------------
# xxxxxxxxxxxxxxxxxxxxxxx --------------------------------------------------
# xxxxxxxxxxxxxxxxxxxxxxx --------------------------------------------------
# xxxxxxxxxxxxxxxxxxxxxxx --------------------------------------------------
# xxxxxxxxxxxxxxxxxxxxxxx --------------------------------------------------
# xxxxxxxxxxxxxxxxxxxxxxx --------------------------------------------------
# xxxxxxxxxxxxxxxxxxxxxxx --------------------------------------------------
# xxxxxxxxxxxxxxxxxxxxxxx --------------------------------------------------
# xxxxxxxxxxxxxxxxxxxxxxx --------------------------------------------------


 DGESVDX Example Program Results

 Singular values of A:
         3.6831        1.3569

 Estimates given as multiples of machine precision
 Error estimate for the singular values
              4

 Error estimates for the left singular vectors
              2          3

 Error estimates for the right singular vectors
              2          2


library(pdq)

arrivRate    = 75
service_rate = 100
service_time = 1/service_rate

#---- Initialize --------------------------------------------------------------

Init("OpenCircuit")
SetComment("A simple M/M/1 queue")

#---- Define the queueing center ----------------------------------------------

CreateNode("server", CEN, FCFS)

#---- Define the workload and circuit type ------------------------------------

CreateOpen("work", arrivRate)

SetWUnit("Customers")
SetTUnit("Seconds")

#---- Define service demand due to workload on the queueing center ------------

SetDemand("server", "work", service_time)

#---- Solve the model ---------------------------------------------------------
#  Must use the CANONical method for an open circuit

Solve(CANON)

#---- Generate a report -------------------------------------------------------

Report()


# Expectation-Maximizaton to fins clusters and alpha, beta, tau parameters
# of each cluster
#
# author: Alberto Lumbreras
library(data.table)
library(neldermead)
library(dfoptim)
#source('optimization.r')

update_responsabilities <- function(df.trees, u, pis, alphas, betas, taus){
  # Compute E(z_uk) over the posterior distribution p(z_uk | X, theta)

  K <- length(alphas) # number of clusters
  Xu <- filter(df.trees, user==u) # all posts from user

  logfactors <- rep(0,K)
  for (k in 1:K){
    logfactors[k] <- log(pis[k]) + sum(apply(Xu, 1, likelihood.post, alphas[k], betas[k], taus[k]))
  }

  logfactors <- logfactors - max(logfactors) # avoid numerical underflow
  denominator <- sum(exp(logfactors))
  responsabilities_u <- exp(logfactors)/denominator
  responsabilities_u
}

# Likelihood computation using the dataframe
likelihood.post <- function(row, alpha, beta, tau){
  c(as.matrix(
       log(alpha * row['popularity'] + beta*(row['parent']==1) + tau^row['lag']) -
       log(2*alpha*(row['t']-1)   + beta + tau*(tau^row['t']-1)/(tau-1))
       )
    )
}

Qopt <- function(params, resp_k, df.trees){
  # sum of E[lnp(X,Z|\theta)] likelihoods for all clusters and all users
  # given the current responsabilities
  # Note that the optimizations can be done separatedly
  a <- resp_k[df.trees$user]
  b <- apply(df.trees, 1, function(x) likelihood.post(x, params[1], params[2], params[3]))
  sum(a*b) # each likelihood b is weighted according to how much dos the user belong to the cluster
}

# Wrapper for the optimization function
# so that the only parameters are the ones to optimize
#cost.function <- function(params){
#  -1*Qopt(alpha=params[1], beta=params[2], tau=params[3], responsabilities[,k], df.trees)
#}

#Qopt.prima <- function(alpha, beta, tau, resp_k, df.trees){
#  sum(apply(df.trees, 1, likelihood.post, alpha, beta, tau))
#}

EM <-function(df.trees, alphas, betas, taus){
  # Expectation-Maximizationo to find groups of users with different
  # alpha, beta, tau parameters
  # Arguments:
  #   trees: a list of igraph objects representing discussion threads
  #   alphas, betas, taus: initial assignment of users to clusters
  K <- length(alphas)
  users <- unique(df.trees$user)
  U <- length(users)

  responsabilities <- matrix(nrow = U, ncol = K)
  pis <- rep(1/ncol(responsabilities), ncol(responsabilities))

  niters <- 10
  traces <- matrix(0, nrow=niters, ncol=K)
  for(iter in 1:niters){
      cat("\n**********ITERATION**********: ", iter, "\n")
      # EXPECTATION
      # Given the parameters of each cluster, find the responsability of each user in each cluster
      #################################################################
      # (this can be parallelizable)
      for (u in 1:U){
        responsabilities[u,] <- update_responsabilities(df.trees, u, pis, alphas, betas, taus)
      }

      #print(responsabilities)
      cat("Best vectors:\n", apply(responsabilities, 1, which.max))

      # MAXIMIZATION
      # Given the current responsabilities and pis, find the best parameters for each cluster
      ################################################################
      for(k in 1:K){
        # Optimization for cluster k
        # neldermead::fminbnd does not deal well with boundaries
        # nlminb and nmkb give the same solution.
        # nmkb is a little bit faster
        # sol <- nlminb(c(alphas[k],betas[k],taus[k]), cost.function,
        #              scale = 1, lower=c(0,0,0), upper=c(Inf, Inf, 1))
        sol <- nmkb(c(alphas[k], betas[k], taus[k]), Qopt,
                    lower = c(0,0,0), upper = c(Inf, Inf, 1),
                    control = list(maximize=TRUE),
                    resp_k = responsabilities[,k], df.trees = df.trees)
        alphas[k] <- sol$par[1]
        betas[k]  <-  sol$par[2]
        taus[k]   <-  sol$par[3]
        traces[iter,k] <- sol$value
      }

      # Update pis
      pis <- colSums(responsabilities)/nrow(responsabilities)

      ###############################################################
      # EVALUATION OF FULL LIKELIHOOD p(X, Z | \theta)
      ###############################################################
      cat("\n\nalphas:", alphas)
      cat("\nbetas:", betas)
      cat("\ntaus:", taus)
  }

  list(alphas=alphas,
       betas=betas,
       taus=taus,
       z=z,
       traces=traces)

}

if(TRUE){
  #load('trees.Rda')

  # True parameters
  alphas <- c(0.1, 0.5, 1)
  betas <- c(1, 6, 3)
  taus <- c(0.7, 0.1, 0.2)

  # The first two posts of every thread are trivial since they have no choice
  df.trees <- filter(df.trees, t>2)

  # Expectation-Maximization
  res <- EM(df.trees, alphas, betas, taus)
  plot(rowSums(res$traces))

  #-7840
  #-7839
  #-7893

}


library(generativeart)
library(tidyverse)

# set the paths
IMG_DIR <- "images/"
IMG_SUBDIR <- "./"
IMG_SUBDIR2 <- "./"
IMG_PATH <- paste0(IMG_DIR, IMG_SUBDIR)

LOGFILE_DIR <- "logfile/"
LOGFILE <- "logfile.csv"
LOGFILE_PATH <- paste0(LOGFILE_DIR, LOGFILE)

# create the directory structure
generativeart::setup_directories(IMG_DIR, IMG_SUBDIR, IMG_SUBDIR2, LOGFILE_DIR)

get_circle_data <- function(center = c(0,0), radius = 1, npoints = 1000){
  tt <- seq(0, 2*pi, length.out = npoints)
  xx <- center[1] + radius * cos(tt)
  yy <- center[2] + radius * sin(tt)
  return(data.frame(x = xx, y = yy))
}

generate_data <- function(df) {
  print("generate data")
  df2 <- df %>%
    mutate(xend = x,
           yend = y) %>%
    select(-x, -y)
  df2 <- df2[sample(nrow(df2)),]
  df <- bind_cols(df, df2)
  return(df)
}

generate_plot <- function(df, file_name, coord, line_color) {
  print("generate plot")
  plot <- df %>%
    ggplot() +
    geom_segment(aes(x = x, y = y, xend = xend, yend = yend), color = line_color, size = 0.25, alpha = 0.6) +
    theme_void() +
    coord_equal()

  print("image saved...")
  plot
}

x <- 3
y <- c(2,2)
n <- 500
df1 <- get_circle_data(center = y, radius = 5, npoints = n)
df2 <- generate_data(df1)
plot <- generate_plot(df2, line_color = "black")

# add background
output_plot <- plot #+ theme(plot.background = element_rect(fill = "#f8d0b0"))
print(output_plot)

# save an image
save_file = FALSE
if (save_file){
  file_name <- paste0(format(Sys.time(), "%Y-%m-%d-%H-%M"),
                      "_center_", y[1], y[2], "_radius_", x, "_npoints_", n,".png")
  ggsave(output_plot, filename = paste(IMG_PATH, file_name, sep = ""), width = 6, height = 6)
}


#' A quantile-quantile plot
#'
#' `geom_qq()` and `stat_qq()` produce quantile-quantile plots. `geom_qq_line()` and
#' `stat_qq_line()` compute the slope and intercept of the line connecting the
#' points at specified quartiles of the theoretical and sample distributions.
#'
#' @eval rd_aesthetics("stat", "qq")
#' @eval rd_aesthetics("stat", "qq_line")
#' @param distribution Distribution function to use, if x not specified
#' @param dparams Additional parameters passed on to `distribution`
#'   function.
#' @inheritParams layer
#' @inheritParams geom_point
#' @section Computed variables:
#' Variables computed by `stat_qq()`:
#' \describe{
#'   \item{sample}{sample quantiles}
#'   \item{theoretical}{theoretical quantiles}
#' }
#' Variables computed by `stat_qq_line()`:
#' \describe{
#'   \item{x}{x-coordinates of the endpoints of the line segment connecting the
#'            points at the chosen quantiles of the theoretical and the sample
#'            distributions}
#'   \item{y}{y-coordinates of the endpoints}
#' }
#' @export
#' @examples
#' \donttest{
#' df <- data.frame(y = rt(200, df = 5))
#' p <- ggplot(df, aes(sample = y))
#' p + stat_qq() + stat_qq_line()
#'
#' # Use fitdistr from MASS to estimate distribution params
#' params <- as.list(MASS::fitdistr(df$y, "t")$estimate)
#' ggplot(df, aes(sample = y)) +
#'   stat_qq(distribution = qt, dparams = params["df"]) +
#'   stat_qq_line(distribution = qt, dparams = params["df"])
#'
#' # Using to explore the distribution of a variable
#' ggplot(mtcars, aes(sample = mpg)) +
#'   stat_qq() +
#'   stat_qq_line()
#' ggplot(mtcars, aes(sample = mpg, colour = factor(cyl))) +
#'   stat_qq() +
#'   stat_qq_line()
#' }
geom_qq <- function(mapping = NULL, data = NULL,
                    geom = "point", position = "identity",
                    ...,
                    distribution = stats::qnorm,
                    dparams = list(),
                    na.rm = FALSE,
                    show.legend = NA,
                    inherit.aes = TRUE) {
  layer(
    data = data,
    mapping = mapping,
    stat = StatQq,
    geom = geom,
    position = position,
    show.legend = show.legend,
    inherit.aes = inherit.aes,
    params = list(
      distribution = distribution,
      dparams = dparams,
      na.rm = na.rm,
      ...
    )
  )
}

#' @export
#' @rdname geom_qq
stat_qq <- geom_qq

#' @rdname ggplot2-ggproto
#' @format NULL
#' @usage NULL
#' @export
StatQq <- ggproto("StatQq", Stat,
  default_aes = aes(y = after_stat(sample), x = after_stat(theoretical)),

  required_aes = c("sample"),

  compute_group = function(data, scales, quantiles = NULL,
                           distribution = stats::qnorm, dparams = list(),
                           na.rm = FALSE) {

    sample <- sort(data$sample)
    n <- length(sample)

    # Compute theoretical quantiles
    if (is.null(quantiles)) {
      quantiles <- stats::ppoints(n)
    } else if (length(quantiles) != n) {
      abort("length of quantiles must match length of data")
    }

    theoretical <- do.call(distribution, c(list(p = quote(quantiles)), dparams))

    new_data_frame(list(sample = sample, theoretical = theoretical))
  }
)


movies = read.csv('movies.csv')
summary(movies)

movies['profit'] = movies$gross - movies$budget

plot(movies$profit, movies$rating)
cor(movies$profit, movies$rating)

abline(lm(movies$profit~movies$rating))

plot(movies$profit, movies$cast_facebook_likes)
cor(movies$profit, movies$cast_facebook_likes)

plot(movies$profit, movies$budget)
cor(movies$profit, movies$budget)

plot(movies$profit, movies$votes)
cor(movies$profit, movies$votes)

plot(movies$profit, movies$reviews)
cor(movies$profit, movies$reviews)

movies_subset = movies[((movies$genre == 'Comedy' | movies$genre == 'Crime') & (movies$year == 2004 | movies$year == 2005)),]

table(movies$genre, movies$year)
prop.table(table(movies$genre, movies$year))


library(tidyverse)
library(xgboost)

ind<-sample(2,nrow(diamonds),replace = T,prob = c(0.7,0.3))
train.set<-diamonds[ind==1,]
test.set<-diamonds[ind==2,]

xgb.train<-bind_cols(select_if(train.set,is.numeric),model.matrix(~cut-1,train.set) %>% as.tibble(),model.matrix(~color-1,train.set) %>% as.tibble(),model.matrix(~clarity-1,train.set) %>% as.tibble())
xgboost.train<-xgb.DMatrix(data = as.matrix(select(xgb.train,-price)),label=xgb.train$price)
xgb.test<-bind_cols(select_if(test.set,is.numeric),model.matrix(~cut-1,test.set) %>% as.tibble(),model.matrix(~color-1,test.set) %>% as.tibble(),model.matrix(~clarity-1,test.set) %>% as.tibble())
xgboost.test<-xgb.DMatrix(data = select(xgb.test,-price) %>% as.matrix(),label=xgb.test$price)

param<-list(eval_metric='rmse',gamma=1,max_depth=6,nthread = 3)
xg.model<-xgb.train(data = xgboost.train,params = param,watchlist = list(test=xgboost.test),nrounds = 500,early_stopping_rounds = 60,
                      print_every_n = 30)

xg.predict<-predict(xg.model,xgboost.test)
mse.xgb<-sqrt(mean((test.set$price-xg.predict)^2))
plot((test.set$price-xg.predict))


# nonlinearTseriesをインストールする
install.packages("nonlinearTseries")

library(nonlinearTseries)

# 0.3の場合
logMap1 <- logisticMap(
  r = 2.5,
  n.sample = 100,
  start = 0.3,
  n.transient=0,
  do.plot = TRUE
)

# 0.4の場合
logMap2 <- logisticMap(
  r = 2.5,
  n.sample = 100,
  start = 0.4,
  n.transient=0,
  do.plot = TRUE
)

# 0.5の場合
logMap3 <- logisticMap(
  r = 2.5,
  n.sample = 100,
  start = 0.5,
  n.transient=0,
  do.plot = TRUE
)

# 0.7の場合
logMap5 <- logisticMap(
  r = 2.5,
  n.sample = 100,
  start = 0.7,
  n.transient=0,
  do.plot = TRUE
)

# 先程定義したものからそれぞれベクトルを作成する(付けた名前自体に特に意味はない)
tsuchinoko <- c(logMap1)
sabaiteiku <- c(logMap2)
Awajishima <- c(logMap3)
guruguru <- c(logMap5)

#見やすさを追求しデータフレーム化を行う
sekkaku <- data.frame("0.3" <- tsuchinoko, "0.4" <- sabaiteiku,
"0.5"<- Awajishima,"0.7" <- guruguru)

sekkaku


# Script R : apply a SVD on a sparse matrix
# Following package have to be installed : install.packages("Matrix","irlba")
#
# Script arguments :
#   - size : file with 3 integer : matrix row,column + non zero count
#   - rowIndexes :
#   - columnIndexes :
#   - values :
#   - output :
#   - svdTargetSize :

library('Matrix')
library('irlba')

args = commandArgs(trailingOnly=TRUE)

sizeFile = file(args[1], "rb")
matrixSize <- readBin(sizeFile, integer(), n = 2, size = 4, endian = "big")
nonZeroCount <- readBin(sizeFile, integer(), n = 1, size = 4, endian = "big")
close(sizeFile)
rm(sizeFile)
cat("Matrix size read, ",nonZeroCount,"non zero count, size",matrixSize[1],"x",matrixSize[2],"\n")

rowIndexFile = file(args[2], "rb")
rowIndexes <-readBin(rowIndexFile, integer(), n = nonZeroCount, size = 4, endian = "big")
close(rowIndexFile)
rm(rowIndexFile)
cat("Row indexes read\n")

columnIndexFile = file(args[3], "rb")
columnIndexes <-readBin(columnIndexFile, integer(), n = nonZeroCount, size = 4, endian = "big")
close(columnIndexFile)
rm(columnIndexFile)
cat("Column indexes read\n")

valuesFile = file(args[4], "rb")
matrixValues <-readBin(valuesFile, integer(), n = nonZeroCount, size = 4, endian = "big")
close(valuesFile)
rm(valuesFile)
cat("Matrix values read\n")

A <- sparseMatrix(rowIndexes,columnIndexes, x = matrixValues,dims = matrixSize)
cat("A matrix created\n")
rm(matrixValues, matrixSize, nonZeroCount, columnIndexes, rowIndexes)
cat("Cleanup finished, svd computing will be launched via irlba\n")

svdResult <- irlba(A, as.numeric(args[6]))$u
cat("SVD computed\n")

outputFile = file(args[5], "wb")
writeBin(c(nrow(svdResult),ncol(svdResult)),outputFile,size = 4,endian = "big")
for(row in 1:nrow(svdResult)) {
  writeBin(svdResult[row,],outputFile,size = 8,endian = "big")
}
close(outputFile)
rm(outputFile, row,A)
cat("Result saved\n")


# File name: iris_dmat.r
# Run: mpiexec -np 4 Rscript iris_dmat.r

rm(list = ls())                                       # Clean environment
library(pbdDMAT, quiet = TRUE)                        # Load library
init.grid()
#if(comm.size() != 4)
#  comm.stop("4 processors are required.")

### Load data
X <- as.matrix(iris[, -5])                            # Dimension 150 by 4
X.cid <- as.numeric(iris[, 5])                        # True id

X <- X[1:10,]
X.cid <- X.cid[1:10]

### Convert to ddmatrix
X.dmat <- as.ddmatrix(X)

### Standardized
X.std <- scale(X.dmat)
#mu <- as.matrix(colMeans(X.std))
#cov <- as.matrix(cov(X.std))
#comm.print(mu)
#comm.print(cov)

### SVD
#X.svd <- svd(X.std)

### Project on column space of singular vectors
#A <- X.svd$u %*% diag(X.svd$d, type="ddmatrix")
#B <- X.std %*% X.svd$v                                # A ~ B
#X.prj <- as.matrix(A[, 1:2])                          # Only useful for plot

### Clustering
library(pmclust, quiet = TRUE)
comm.set.seed(123, diff = TRUE)

X.dmat <- X.std
PARAM.org <- set.global.dmat(K = 3)                   # Preset storage
.pmclustEnv$CONTROL$debug <- 0                        # Disable debug messages
PARAM.org <- initial.center.dmat(PARAM.org)
PARAM.kms <- kmeans.step.dmat(PARAM.org)              # K-means
X.kms.cid <- as.vector(.pmclustEnv$CLASS.dmat)

### Validation
X.kms.adjR <- EMCluster::RRand(X.cid, X.kms.cid)$adjRand
comm.print(X.kms.adjR)

### Swap classification id
tmp <- X.kms.cid
X.kms.cid[tmp == 1] <- 3
X.kms.cid[tmp == 2] <- 1
X.kms.cid[tmp == 3] <- 2

### Display on first 2 components
if(comm.rank() == 0){
  pdf("dmat_plot.pdf")

  par(mfrow = c(2, 2))
  plot(X.prj, col = X.cid + 1, pch = X.cid,
       main = "iris (true)", xlab = "PC1", ylab = "PC2")
  plot(X.prj, col = X.kms.cid + 1, pch = X.kms.cid,
       main = paste("iris (kmeans)", sprintf("%.4f", X.kms.adjR)),
       xlab = "PC1", ylab = "PC2")
  dev.off()
}

### Finish
finalize()


## Author: Sergio García Prado
## Title: Statistical Inference - Goodness of Fit - Exercise 19

rm(list = ls())

library(nortest)

observed <- c(9.8, 10.2, 9.3, 12.2, 9.6, 8.6, 8.7, 15.2, 15.5, 11.6, 7.2, 6.9)

test <- sf.test(observed)

(pvalue <- test$p.value)
# 0.222472184638491