# R code
# Luis P. F. Garcia 2018
# Evaluation measures

accuracy <- function(true, pred) {
  sum(diag(table(true, pred)))/sum(table(true, pred))
}

kappa <- function(true, pred) {

  aux = table(pred, true)
  pc = sum(apply(aux, 1, sum)/sum(aux) * apply(aux, 2, sum)/sum(aux))

  if(pc == 1 | is.nan(pc)) pc = 0;
  aux = (sum(diag(aux))/sum(aux) - pc)/(1 - pc)
  return(aux)
}

f1 <- function(true, pred) {
  p = diag(table(true, pred))/colSums(table(true, pred))
  r = diag(table(true, pred))/rowSums(table(true, pred))
  (2 * p * r) / (p + r)
}

performance <- function(true, prob) {

  clas = colnames(prob)
  true = factor(true, levels=clas)
  pred = factor(clas[apply(prob, 1, which.max)], levels=clas)
  c(acc=accuracy(true, pred), kappa=kappa(true, pred),
    f1=mean(f1(true, pred)))
}


#CSA = Cluster Soccer Analysis
rm(list = ls())
cat("\014")

path <- dirname(parent.frame(2)$ofile)
setwd(path)

#call the utility.r file for usefull environment and dataset functions
source("utility.R")

environmentSettings()

environmentSettings()

FinalDatasetLight <- loadDataset(path, "FinalDatasetLight.csv")

FinalDatasetLight <- trasformDataset(FinalDatasetLight)

avg_scores <- FinalDatasetLight %>% select(-player_name, -strong_foot, -quote, -birthday, -work_rate_att, -work_rate_def)
#select(FinalDatasetLight, -player_name)

#principal component analysis
avg_scores_pca=prcomp(avg_scores,scale. = T)

#using a smooth scatter because too many points prevent from
#seeing the global picture
smoothScatter(avg_scores_pca$x[,1:2],nrpoints = 0,
              colramp = colorRampPalette(c("white", "gray5")))

#Implement the Gaussian Mixture Model
xyMclust <- Mclust(data.frame (avg_scores_pca$x[,1],avg_scores_pca$x[,2]),3)
plot(xyMclust,what = "uncertainty",main=FALSE,xlab="PC1",ylab = "PC2")

player_class=xyMclust$classification
#number of players in each cluster
table(player_class)

cat("\n--------\n")

#examples of players from each cluster 1 (Difensori)
cluster1Names <- as.numeric(names(player_class[player_class==1][1:20]))
FinalDatasetLight[cluster1Names,ncol(FinalDatasetLight)] %>% print()

cat("\n--------\n")

#examples of players from each cluster 2 (Portieri)
cluster2Names <- as.numeric(names(player_class[player_class==2][1:20]))
FinalDatasetLight[cluster2Names,ncol(FinalDatasetLight)] %>% print()

cat("\n--------\n")

#examples of players from each cluster 3 (Offensivi)
cluster3Names <- as.numeric(names(player_class[player_class==3][1:20]))
FinalDatasetLight[cluster3Names,ncol(FinalDatasetLight)] %>% print()

cat("\n--------\n")

player_class[which(player_class==1)]="difensivi"
player_class[which(player_class==2)]="offensivi"
player_class[which(player_class==3)]="portieri"
player_class=factor(player_class, levels = c("difensivi", "offensivi", "portieri"))

#CROSS CHECK
#Permette di verificare quanto le feature sono correlate rispetto al ruolo del cluster di ognuno dei 3 ruoli individuati
#TODO: trovare i valori giusti di k per estrarre le feature
#offensivi (finishing)
k <- which(colnames(avg_scores)=="finishing")
boxplot(avg_scores[,k]~player_class,main=colnames(avg_scores)[k],
        ylab="Average Score")

#portieri (gk_diving)
k <- which(colnames(avg_scores)=="gk_diving")
boxplot(avg_scores[,k]~player_class,main=colnames(avg_scores)[k],
        ylab="Average Score")

#difensivi (interceptions)
k <- which(colnames(avg_scores)=="interceptions")
boxplot(avg_scores[,k]~player_class,main=colnames(avg_scores)[k],
        ylab="Average Score")

#border players (min probabilities)
tot=data.frame(player_class,xyMclust$z[,1:3])
tot$player_name = FinalDatasetLight$player_name
colnames(tot)[2:4]=c("prob_difensivo","prob_offensivo","prob_portiere")

defensive=tot[which(tot[,1]=="difensivi"),]
offensive=tot[which(tot[,1]=="offensivi"),]
goalkeper=tot[which(tot[,1]=="portieri"),]

cat("\n--------")
print("MOLTO DIFENSIVI")
#very defensive
head(defensive[order(defensive[,2],decreasing = T),]) %>% print()
top_n(defensive[order(defensive[,2],decreasing = T),],10) %>% print()

cat("\n--------")
print("MOLTO OFFENSIVI")
#very offensive
head(offensive[order(offensive[,3],decreasing = T),]) %>% print()
top_n(offensive[order(offensive[,3],decreasing = T),],10) %>% print()

cat("\n--------")
print("MOLTO PORTIERI")
#very goalKeaper
head(goalkeper[order(goalkeper[,4],decreasing = T),]) %>% print()
top_n(goalkeper[order(goalkeper[,4],decreasing = T),],10) %>% print()

#border line, difficoult to say something
cat("\n--------\n")
print("BORDERLINE TRA DIFENSIVI E OFFENSIVI")
head(defensive[order(defensive[,2]),]) %>%  print()


sort <- function() {
  for (i in floor(n / 2):1) {
    heapify(n, i)
  }
  for (i in n:1) {
    t <- p[1]
    p[1] <<- p[i]
    p[i] <<- t
    heapify(i, 1)
  }
}
heapify <- function(n, i) {
  largest = i
  l = 2 * i
  r = 2 * i + 1
  if ((l < n) && (p[l] > p[largest])) {
    largest <- l
  }
  if ((r < n) && (p[r] > p[largest])) {
    largest <- r
  }
  if (largest != i) {
    t <- p[i]
    p[i] <<- p[largest]
    p[largest] <<- t
    heapify(n, largest)
  }
}

startTime <- Sys.time()
p <- c(4, 10, 3, 5, 1)
n <- length(p)
sort()
print("Sorted array is ")
print(p)
endTime <- Sys.time()
timeTaken <- endTime - startTime
cat("Time required : ", as.numeric(timeTaken), "\n")


source('fmm_utils.r')

mixing_model    = function(k, a) drop(rdirichlet(1, (rep(a, k))))
label_model     = function(n, p) drop(rmultinom(1, size = n, prob = p))
location_model  = function(k, l, r) rnorm(k, l, sqrt(1 / r))
precision_model = function(k, b, w) rgamma(k, b, 1 / w)

parameter_model = function(k, n) {
  p  = mixing_model(k, 1)
  c  = label_model(n, p)
  mu = location_model(k, 0, 0.1)
  s  = precision_model(k, 1, 1)
  list(c, mu, s)
}

data_model = function(config) {
  sampler = function(y, m, s) rnorm(y, m, 1 / s)
  mapply(sampler, config[[1]], config[[2]], config[[3]])
}

model = function(k, n) {
  params = parameter_model(k, n)
  data_model(params)
}

lmodel = function(y, p, m, s) {
  score      = function(pr, mu, prec) { pr * dnorm(y, mu, sqrt(1 / prec)) }
  by_cluster = mapply(score, p, m, s)
  totalled   = apply(by_cluster, MARGIN = 1, sum)

  # NOTE (jtobin): adjusted for numerical stability
  small    = 1.379783e-316
  adjusted = totalled
  adjusted[which(adjusted == 0)] = small
  sum(log(adjusted))
}


## Function to do Wright-Fisher simulation with selection and a finite sample size
# using set Ne, s, and initial allele frequency
# Sample each generation

# f1: the initial allele frequency uniform prior
# s: the selection coefficient uniform prior
# cnt: the size of the samples (in # chromosomes)
# gen: the number of generations
# ne: Ne value
# h: dominance effect

wfs_ts <- function(f1=0, s=0, cnt=50, gen=20, ne=100, h=0.5){
	p <- rep(NA, gen)
	fsamp <- p

	p[1] <- f1 # current allele frequency
	fsamp[1] <- rbinom(1,cnt,p[1])/cnt # first sample allele frequency
	waa <- 1+s # relative fitness of genotype AA
	wab <- 1+s*h
	wbb <- 1
	for(i in 2:gen){
		x <- (waa*p[i-1]^2 + wab*p[i-1]*(1-p[i-1]))/(waa*p[i-1]^2 + wab*2*p[i-1]*(1-p[i-1]) + wbb*(1-p[i-1])^2) # probability of sampling allele A, given selection
		p[i] <- rbinom(1,ne,x)/ne
		fsamp[i] <- rbinom(1,cnt,p[i])/cnt # first sample allele frequency
#		print(paste(x,p))
	}

	# return values
	out <- list(gen=1:gen, p=p, fsamp=fsamp)
	return(out)
}


do_summary_simple_mean <- function (x, target_var){

	# calculates simple (i.e., not stratified) mean statistics
	# Nuno Prista, SLU Aqua, Sweden
	# Developed @ KustMonitoring Review 2019

	#x is a dataframe or data.table with
		# # target values in target_var variable

	# 2019-05-06: added clow_mean and chigh_mean (confidence intervals)

# ==========================
# Non-stratified (Nst) results
# ==========================

	values<-x[[target_var]]
	# simple mean
		Nst_mean<-mean(values)
	# simple_var_mean
		Nst_var_mean<-var(values)/length(values)
	# simple se of the mean
		Nst_se_mean<-sd(values)/sqrt(length(values))
	# simple cv/rse of the mean
			Nst_rse_mean<-round(Nst_se_mean/Nst_mean*100,1)

	list(pop_res = data.frame(type = "simple", variable = target_var,  n_tot = length(values), n_strata = NA, mean = Nst_mean, var_mean = Nst_var_mean, se_mean = Nst_se_mean, rse_mean = Nst_rse_mean, clow_mean=Nst_mean-2*Nst_se_mean, chigh_mean=Nst_mean+2*Nst_se_mean), stratum_res = NULL, type="stratified")

}


rm(list = ls())

#load data
meth_level <- read.csv("meth_level.csv", header = T, stringsAsFactors = F)
meth_level <- as.numeric(meth_level$X0)
idx <- which(!is.na(meth_level))
meth_level <- meth_level[idx]

meth_prob <- read.csv("meth_prob.csv", header = T, stringsAsFactors = F)
meth_prob <- meth_prob$pred_prob
meth_prob <- meth_prob[idx]

#correlation analysis
cor(meth_level, meth_prob, method = "spearman")
#0.3461575

#boxplot
grade <- ceiling(meth_level*10)
df <- data.frame(score = meth_prob, level = grade)
df <- df[df$level != 0,]

pdf('Correlation.pdf')
boxplot(score~level, data=df, notch=TRUE,
        col=(c("gold","darkgreen")),
        main="Caenorhabditis elegans",
        xlab="Methylation Level", ylab = "Predicted Score")
dev.off()


## estimate effect sizes from association tests of features
## se standard errors of the coefficients
## mat input data matrix (features x samples)
ivwfe.stats <- function(estimate, se, mat=NULL, rho=NULL) {
    ## http://onlinelibrary.wiley.com/doi/10.1002/sim.6835/full
    ## calculate rho
    if (is.null(rho)) {
        stopifnot(!is.null(mat))
        rho <- ivwfe.rho(mat)
    }
    ## remove missing values
    na <- is.na(estimate) | is.na(se)
    if (sum(na) > 0) {
        if (sum(na) == length(estimate))
            return(c(B=NA, S=NA))

        estimate <- estimate[!na]
        se <- se[!na]
        rho <- rho[!na,!na,drop=F]
    }
    ## calculate statistics
    ivwfe.stats0 <- function(estimate, se, rho) {
        tryCatch({
            omega <- (se%*%t(se))*rho
            omega.inv <- solve(omega)
            one <- matrix(1,nrow=nrow(omega.inv), ncol=1)
            S2 <- 1/(t(one) %*% omega.inv %*% one)
            c(B=S2 * (t(one) %*% omega.inv) %*% estimate,
              S=sqrt(S2))
        }, error=function(e) {
            c(B=NA,S=NA)
        })
    }
    return(ivwfe.stats0(estimate, se, rho))
}

ivwfe.getz <- function(estimate, se, mat=NULL, rho=NULL) {
    stats <- ivwfe.stats(estimate, se, mat, rho)
    as.vector(stats["B"]/stats["S"])
}

ivwfe.rho <- function(mat) {
    mat <- t(mat)
    ## correlation matrix + nudge (to ensure invertible)
    rho <- cor(mat, use="p") + diag(x=0.05,ncol(mat),ncol(mat))
}

ivwfe.ma <- function(estimates, se) {
    weights <- 1/se^2
    se <- sqrt(1/rowSums(weights, na.rm=T))
    estimates <- rowSums(estimates * weights, na.rm=T)/rowSums(weights, na.rm=T)
    z <- estimates/se
    p <- 2*pnorm(-abs(z), lower.tail=T)
    data.frame(estimate=estimates,
               se=se,
               z=z,
               p.value=p)
}


century <- function(year) ( year + 99 ) %/% 100


# Load the data and take a look at it.
data <- read.csv("C:\\Users\\gashort\\Documents\\Presentations\\DataScienceForFunAndProfit\\LogisticRegression\\Data.csv");
head(data);

# Predict win/lose based on mile time and weight
logit <- glm(Win~MileTime+Weight, data=data, family="binomial");

summary(logit);

# "Decode" the coefficients
exp(coef(logit))


evalWithAB <- function(expr, var, a, b) {
  env <- new.env()           # provide a separate env, so that the choosen
  assign(var, a, envir=env)  # var name do not collide with symbols inside
                             # this function (e.g. it could be even "env")
  atA <- eval(parse(text=expr), env)
                             # and then evaluate the expression inside this
                             # ad hoc env-ironment
  assign(var, b, envir=env)
  atB <- eval(parse(text=expr), env)
  return(atB - atA)
}

print(evalWithAB("2*x+1", "x", 5, 3))
print(evalWithAB("2*y+1", "y", 5, 3))
print(evalWithAB("2*y+1", "x", 5, 3)) # error: object "y" not found


#' Estimating the inverse first-order reliability method (IFORM) environmental contours
#'
#' @description
#' This function estimates the Invserse FORM (IFORM) environmental contours, as proposed in Winterstein et al. (1993)
#' for a given sample data set or a fitted joint distribution of class \code{ht} or \code{wln}.
#'
#' @param object either a fitted joint distribution of class \code{wln} or \code{ht}, or an existing sample data
#' set containing \code{hs} and \code{tp} as columns. See details.
#'
#' @param output_rp the required return periods (in years) for the estimated contours.
#'
#' @param npy the (optional) number of data points per year. This argument is only needed if the input
#' \code{object} is a sample data set.
#'
#' @param n_point the number of points to output around each contour. The default value is 100.
#'
#' @param alpha0 the omission factor for the IFORM contours. The default value is 0, meaning no
#' inflation to the estimated contours.
#'
#' @details
#' The IFORM contour is constructed based on the first-order reliability method (FORM) and
#' it searches a hypersphere of constant radius to find the maximum response.
#'
#' The function can be applied to an existing sample set, which can be generated by function \code{\link{sample_jdistr}}
#' or otherwise by importing a CSV file using function \code{\link[data.table]{fread}}. The input sample data
#' object must contain \code{hs} and \code{tp} as columns. The user must also specify the number of points per year
#' \code{npy} and a valid \code{output_rp}, i.e. the maximum \code{output_rp} must be shorter than the total
#' duration of the data set.
#'
#' Alternatively this function can be applied to a fitted joint distribution object
#' generated by function \code{\link{fit_ht}} or \code{\link{fit_wln}}.  When applied to a \code{ht} object,
#' the estimated contour is a blending between the two conditional models \eqn{Hs|Tp>tp} and \eqn{Tp|Hs>hs} above
#' high thresholds \eqn{tp} and \eqn{hs}, as specified in Heffernan and Tawn (2004).
#'
#' @return A set of estimated IFORM contours with the specified return periods in the format
#' of a \code{data.table} with \code{rp}, \code{hs}, and \code{tp} as columns.
#'
#' @examples
#' # Estimating IFORM contours based on a fitted model
#' data(ww3_pk)
#' ht = fit_ht(data = ww3_pk, npy = nrow(ww3_pk)/10, margin_thresh_count = 50, dep_thresh_count = 500)
#' ec_ht = estimate_iform(object = ht, output_rp = c(10,100,1000,10000))
#' plot_ec(ec = ec_ht, raw_data = ww3_pk)
#'
#' # Estimating IFORM contours based on a sample data set
#' data(ww3_ts)
#' ec_data = estimate_iform(object = ww3_ts, output_rp = c(.5, 1, 2), npy = ww3_ts[, .N/10])
#' plot_ec(ec = ec_data, raw_data = ww3_ts)
#'
#' @references
#' Winterstein, S. R., Ude, T. C., Cornell, C. A., Bjerager, P., Haver, S., 1993. Environmental parameters
#' for extreme variable: Inverse Form with omission factors. In: Proc. 6th Int. Conf. on
#' Structural Safety and Reliability, Innsbruck, Austria.
#'
#' Heffernan, Janet & A. Tawn, Jonathan. (2004). A Conditional Approach for Multivariate Extreme Values.
#' Journal of the Royal Statistical Society Series B. 66. 497-546. 10.1111/j.1467-9868.2004.02050.x.
#'
#' @seealso \code{\link{fit_ht}}, \code{\link{fit_wln}}, \code{\link{sample_jdistr}}, \code{\link{plot_ec}}
#'
#' @export
estimate_iform = function(
  object, output_rp, npy = NULL, n_point=100, alpha0=0){

  if("wln" %in% class(object)){

    res = .estimate_iform_from_wln(wln = object, output_rp = output_rp, n_point = n_point, alpha0 = alpha0)
    if(!is.null(npy)){
      warning("Argument npy will be imported from the provided joint distribution object.  The supplied npy is ignored.")
    }

  }else if("ht" %in% class(object)){

    res = .estimate_iform_from_ht(ht = object, output_rp = output_rp, n_point = n_point, alpha0 = alpha0)
    if(!is.null(npy)){
      warning("Argument npy will be imported from the provided joint distribution object.  The supplied npy is ignored.")
    }

  }else if("data.table" %in% class(object)){

    if(is.null(npy)){
      stop("Argument npy must be provided for estimating contours from sample data.")
    }else{
      invalid_rp = output_rp[output_rp>object[, .N/npy]]
      if(length(invalid_rp)==length(output_rp)){
        stop("All output_rp values are invalid as they require extrapolation. Consider fitting a joint distribution first.")
      }else if(length(invalid_rp)>=1 & length(invalid_rp)<length(output_rp)){
        warning("Certain output_rp values are ignored as they requires extrapolation. Consider fitting a joint distribution first.")
      }
      output_rp = setdiff(output_rp, invalid_rp)
    }

    res = .estimate_iform_from_sample_data(
      sample_data = object, sample_data_npy = npy,
      output_rp = output_rp, n_point = n_point, alpha0 = alpha0)

  }else{

    stop("The input object must be of class ht, wln or data.table.")
  }

  return(res)
}

# Sub functions -----------------------------------------------------------

.estimate_iform_from_sample_data = function(sample_data, sample_data_npy, output_rp, n_point, alpha0){

  # Calculate beta and inflate
  prob = 1 - 1/(sample_data_npy*output_rp)
  beta = qnorm(prob)
  beta_star = beta / (sqrt(1-(alpha0^2)))

  # Define points
  angle = seq(0, 2*pi, length.out = n_point+1)
  calc = data.table(rp = rep(output_rp, each=n_point+1), angle = angle)
  calc[, u1:=rep(beta_star, each=n_point+1)*cos(angle)]
  calc[, u2:=rep(beta_star, each=n_point+1)*sin(angle)]
  calc[, p1:=pnorm(u1)]
  calc[, p2:=pnorm(u2)]
  calc[, hs:=quantile(sample_data$hs, p1, names = F)]

  for(i in 1:calc[, .N]){
    cond_distr_bw = calc[rp==calc[i]$rp, bw.SJ(hs)]
    td_data = sample_data[abs(hs-calc$hs[i])<=cond_distr_bw/2]
    if(td_data[,.N]<.knn){
      td_data = sample_data[sort.list(abs(hs-calc$hs[i]))[1:.knn]]
    }
    calc[i, tp:=quantile(td_data$tp, p2, names = F)]
  }

  # Return
  res = calc[, .(rp, hs, tp)]
  return(res)
}

.estimate_iform_from_wln = function(wln, output_rp, n_point, alpha0){

  # Calculate beta and inflate
  prob = 1 - 1/(wln$npy*output_rp)
  beta = qnorm(prob)
  beta_star = beta / (sqrt(1-(alpha0^2)))

  # Define points
  angle = seq(0, 2*pi, length.out = n_point+1)
  calc = data.table(rp = rep(output_rp, each=n_point+1), angle = angle)
  calc[, u1:=rep(beta_star, each=n_point+1)*cos(angle)]
  calc[, u2:=rep(beta_star, each=n_point+1)*sin(angle)]
  calc[, p1:=pnorm(u1)]
  calc[, p2:=pnorm(u2)]
  calc[, hs:=qweibull(p1, shape=wln$hs$par["shape"], scale=wln$hs$par["scale"])+wln$hs$par["loc"]]
  calc[, m:=wln$tp$par[1] + wln$tp$par[2] * (hs ^ wln$tp$par[3])]
  # calc[, s:=wln$tp$par[4] + wln$tp$par[5] * exp(wln$tp$par[6] * hs)]
  calc[, s:=pmax(.limit_zero, wln$tp$par[4] + wln$tp$par[5] * exp(wln$tp$par[6] * hs))]
  calc[, tp:=qlnorm(p2, m, s)]

  # Return
  res = calc[, .(rp, hs, tp)]
  return(res)
}

.estimate_iform_from_ht = function(ht, output_rp, n_point, alpha0){

  p_thresh = ht$margin$p_margin_thresh
  n_exceed = length(ht$margin$hs$emp)*(1-p_thresh)

  # Calculate beta and inflate
  prob = 1 - 1/(ht$npy*output_rp)
  beta = qnorm(prob)
  beta_star = beta / (sqrt(1-(alpha0^2)))

  # Define points
  angle = seq(0, 2*pi, length.out = n_point+1)
  calc = data.table(rp = rep(output_rp, each=n_point+1), angle = angle)
  calc[, u1:=rep(beta_star, each=n_point+1)*cos(angle)]
  calc[, u2:=rep(beta_star, each=n_point+1)*sin(angle)]
  calc[, p1:=pnorm(u1)]
  calc[, p2:=pnorm(u2)]

  # Estimate hs based on hs model
  calc_hs = calc[p1>ht$dep$p_dep_thresh]
  calc_hs[, hs:=.convert_unif_to_origin(
    unif = p1, p_thresh = p_thresh, gpd_par = ht$margin$hs$par, emp = ht$margin$hs$emp)]

  # Estimate tp based on tp|hs HT model for large hs
  calc_hs[, lap1:=.convert_unif_to_lap(p1)]
  calc_hs[, resid_q:=quantile(ht$dep$hs$resid, p2)]
  calc_hs[,lap2:=ht$dep$hs$par[1]*lap1+resid_q*lap1^ht$dep$hs$par[2]]
  calc_hs[, p_tp:=.convert_lap_to_unif(lap2)]
  calc_hs[, tp:=.convert_unif_to_origin(
    unif = p_tp, p_thresh = p_thresh, gpd_par = ht$margin$tp$par, emp = ht$margin$tp$emp)]

  # Estimate tp based on tp model
  calc_tp = calc[p2>ht$dep$p_dep_thresh]
  calc_tp[, tp:=.convert_unif_to_origin(
    unif = p2, p_thresh = p_thresh, gpd_par = ht$margin$tp$par, emp = ht$margin$tp$emp)]

  # Estimate hs based on hs|tp HT model for large tp
  calc_tp[, lap2:=.convert_unif_to_lap(p2)]
  calc_tp[, resid_q:=quantile(ht$dep$tp$resid, p1)]
  calc_tp[,lap1:=ht$dep$tp$par[1]*lap2+resid_q*lap2^ht$dep$tp$par[2]]
  calc_tp[, p_hs:=.convert_lap_to_unif(lap1)]
  calc_tp[, hs:=.convert_unif_to_origin(
    unif = p_hs, p_thresh = p_thresh, gpd_par = ht$margin$hs$par, emp = ht$margin$hs$emp)]

  # Return
  res = merge(
    x = calc_hs[, .(rp, angle, hs, tp)], y = calc_tp[, .(rp, angle, hs, tp)],
    by=c("rp", "angle"), all=T)
  res[is.na(hs.x), hs:=hs.y]
  res[is.na(tp.x), tp:=tp.y]
  res[is.na(hs.y), hs:=hs.x]
  res[is.na(tp.y), tp:=tp.x]
  res[!is.na(hs.x+hs.y), hs:=hs.x*cos(angle)^2+hs.y*sin(angle)^2]
  res[!is.na(hs.x+hs.y), tp:=tp.x*cos(angle)^2+tp.y*sin(angle)^2]
  setkey(res, rp, angle)
  return(res[, .(rp, hs, tp)])
}


##Ambientación = group
##Raster=raster
##Ambientes=vector polygon
##Zonas=field Ambientes
##muestras=number 300
##output_plots_to_html

if("nlme" %in% rownames(installed.packages()) == FALSE) {install.packages("nlme")} else {print("nlme ya esta..")}
if("multcomp" %in% rownames(installed.packages()) == FALSE) {install.packages("multcomp")} else {print("multcomp ya esta..")}
if("multcompView" %in% rownames(installed.packages()) == FALSE) {install.packages("multcompView")} else {print("multcompView ya esta..")}
if("lsmeans" %in% rownames(installed.packages()) == FALSE) {install.packages("lsmeans")} else {print("lsmeans ya esta..")}

require(sf)
require(nlme)
require(multcomp)
require(multcompView)
require(lsmeans)

Ambientes <- as_Spatial(Ambientes)

crs<-proj4string(Ambientes)
rendimiento<-as(Raster, "SpatialPixelsDataFrame")
colnames(rendimiento@data)<-c("rinde")

str(rendimiento@data)
z<-rendimiento@data["rinde"]
x<-rendimiento@coords[,1]
y<-rendimiento@coords[,2]

print(length(rendimiento@data))
rendimiento <- data.frame(x,y,z)

rendimiento <-rendimiento[sample(nrow(rendimiento),as.integer(muestras)),]
coordinates(rendimiento)<-c("x","y")

proj4string(rendimiento) <- crs
proj4string(Ambientes) <- crs

muestra<-cbind(rendimiento@data,rendimiento@coords[,1],rendimiento@coords[,2],over(rendimiento,Ambientes[,Zonas]))
muestra<-data.frame(muestra)

colnames(muestra)<-c("rinde","X","Y","Zona")

colnames(muestra)

muestra$Zona<-as.factor(muestra$Zona)
muestra<-na.omit(muestra)

# Model with exponencial spatial correlation
mod1_Wy <-gls(rinde~1+Zona
              ,correlation=corExp(form=~as.numeric(as.character(X))+as.numeric(as.character(Y))
                                  ,metric="euclidean"
                                  ,nugget=FALSE)
              ,method="REML"
              ,na.action=na.omit
              ,data=muestra)
# Model with exponential spatial correlation and nugget effect
mod2_Wy <-gls(rinde~1+Zona
              ,correlation=corExp(form=~as.numeric(as.character(X))+as.numeric(as.character(Y))
                                  ,metric="euclidean"
                                  ,nugget=TRUE)
              ,method="REML"
              ,na.action=na.omit
              ,data=muestra)

# AModel with spherical spatial correlation
mod3_Wy <-gls(rinde~1+Zona
              ,correlation=corSpher(form=~as.numeric(as.character(X))+as.numeric(as.character(Y))
                                    ,metric="euclidean"
                                    ,nugget=FALSE)
              ,method="REML"
              ,na.action=na.omit
              ,data=muestra)

# Model with spherical spatial correlation and nugget effect
mod4_Wy <-gls(rinde~1+Zona
              ,correlation=corSpher(form=~as.numeric(as.character(X))+as.numeric(as.character(Y))
                                    ,metric="euclidean"
                                    ,nugget=TRUE)
              ,method="REML"
              ,na.action=na.omit
              ,data=muestra)

# Model of independent errors
mod5_Wy <-gls(rinde~1+Zona
              ,method="REML"
              ,na.action=na.omit
              ,data=muestra)

# Selecting spatial correlation model using the Akaike information criterion
AICmod1_Wy <- AIC(mod1_Wy)
AICmod2_Wy <- AIC(mod2_Wy)
AICmod3_Wy <- AIC(mod3_Wy)
AICmod4_Wy <- AIC(mod4_Wy)
AICmod5_Wy <- AIC(mod5_Wy)

modelos<-c("mod1_Wy","mod2_Wy","mod3_Wy","mod4_Wy","mod5_Wy")
criterio<-c(AICmod1_Wy,AICmod2_Wy,AICmod3_Wy,AICmod4_Wy,AICmod5_Wy)

modelofinal<-AICmod1_Wy
indicefinal <- 1

for (i in 1:5){
  if(criterio[i] < modelofinal){indicefinal = i}
}

summary(get(modelos[indicefinal]))
#Wymeans <- summary(lsmeans(get(modelos[indicefinal]),"Zone")); Wymeans

require(lsmeans)
modelo.lm<-lsmeans(get(modelos[indicefinal]),"Zona")
Wymeans <- summary(modelo.lm)

require(multcompView)
require(multcomp)

valores<-cld(modelo.lm, Letters = c("a","b","c","d","e"),sort=TRUE,reversed=TRUE)
letras<- c(valores$.group)
#letras<-letras[length(letras):1]

Wymean <-by(Wymeans$lsmean,Wymeans$Zona,mean)
Wyse<-by(Wymeans$SE,Wymeans$Zona,mean)
wy <- barplot(Wymean,xlab="Zonas de manejo", ylab="Rendimiento",
              ,ylim=c(0,max(max(Wymean)+max(Wymean)*0.1)),xpd=F)

letters = letras
text(x=wy,y=Wymean+Wymean*0.05,label=letters,cex = 1)


suppressMessages(library(ksvd))
init.grid()

.pbd_env$BLDIM = c(2, 2)
m = 6
n = 5
x = ddmatrix("rnorm", m, n)

# ret = ksvd(x, nu=0, nv=0)
# comm.print(rev(ret$d))
# ret = La.svd(x, nu=0, nv=0)
# comm.print(ret$d)

ret = ksvd(x)
comm.print(head(ret$d))
ret = La.svd(x, nu=0, nv=0)
comm.print(head(ret$d))

# .pbd_env$bldim = c(64, 64)
# m = 512
# n = 512
# x = ddmatrix("rnorm", m, n)
#
# ret = comm.timer(d_ksvd <- ksvd(x)$d)
# comm.print(ret)
# d_ksvd = rev(d_ksvd)
# ret = comm.timer(d_svd <- La.svd(x)$d)
# comm.print(ret)
#
# comm.print(head(d_ksvd))
# comm.print(head(d_svd))
# comm.print(all.equal(d_ksvd, d_svd))

finalize()


 DPTTRF Example Program Results

 Details of factorization

  The diagonal elements of D
    4.0000   9.0000  25.0000  16.0000   1.0000

  Subdiagonal elements of the Cholesky factor L
   -0.5000  -0.6667   0.6000   0.5000


## Check that the median is NA when there is lots of censoring
require(rms)
n <- 1000
set.seed(731)
age <- 50 + 12*rnorm(n)
label(age) <- "Age"
sex <- factor(sample(c('Male','Female'), n,
                     rep=TRUE, prob=c(.6, .4)))
cens <- 15*runif(n)
h <- .02*exp(.04*(age-50)+.8*(sex=='Female'))
dt <- -log(runif(n))/h
label(dt) <- 'Follow-up Time'
e <- ifelse(dt <= cens,1,0)
dt <- pmin(dt, cens)
units(dt) <- "Year"
dd <- datadist(age, sex)
options(datadist='dd')
S <- Surv(dt,e)

f <- cph(S ~ age + strat(sex), surv=TRUE)
g <- cph(S ~ age + sex, surv=TRUE)
h <- f  # set to f for strat(sex), g for covariate adj for sex
par(mfrow=c(2,2))
for(a in c(45, 55, 65, 75)) {
  survplot(h, sex, age=a)
  title(paste0('Age=', a))
  abline(h=0.5, col=gray(.85))
}

ggplot(Predict(h, age=20:80, sex, time=11))
ggplot(Predict(h, age=20:80, sex, time=12))
ggplot(Predict(h, age=20:80, sex, time=13))
ggplot(Predict(h, age=20:80, sex, time=14))

quan <- Quantile(h)
med  <- function(x) quan(lp=x, stratum=2)
ages <- 70:80
Predict(h, age=ages, sex='Male')$yhat
lp <- predict(h, data.frame(sex='Male', age=ages))
data.frame(age=ages, lp=lp, median=med(lp))

## Estimate survival curves at these medians
if(length(h$strata)) {
  times <- h$time[['sex=Male']]
  surv  <- h$surv[['sex=Male']]
} else {
  times <- h$time
  surv  <- h$surv
}
for(l in lp) print(approx(times, surv ^ exp(l), xout=med(l))$y)

p <- Predict(h, age=ages, fun=med)
plot(p)


# load packages needed to run this code
library(ggplot2)
library(dplyr)
library(tidyr)
library(cowplot)
library(gganimate)
library(magick)

# this function calculates true positive rate and false positive rate to make an ROC curve
calc_ROC <- function(probabilities, known_truth, model.name = NULL) {
  outcome <- as.numeric(factor(known_truth)) - 1
  pos <- sum(outcome) # total known positives
  neg <- sum(1 - outcome) # total known negatives
  pos_probs <- outcome * probabilities # probabilities for known positives
  neg_probs <- (1 - outcome) * probabilities # probabilities for known negatives
  true_pos <- sapply(
    probabilities,
    function(x) sum(pos_probs >= x) / pos
  ) # true pos. rate
  false_pos <- sapply(
    probabilities,
    function(x) sum(neg_probs >= x) / neg
  )
  if (is.null(model.name)) {
    result <- data.frame(true_pos, false_pos)
  } else {
    result <- data.frame(true_pos, false_pos, model.name)
  }

  result %>% add_row(true_pos = 0, false_pos = 0) %>% arrange(false_pos, true_pos)
}

# this function calculates precision and recall
calc_PR <- function(probabilities, known_truth, model.name = NULL) {
  outcome <- as.numeric(factor(known_truth)) - 1
  pos <- sum(outcome) # total known positives
  pos_probs <- outcome * probabilities # probabilities for known positives
  neg_probs <- (1 - outcome) * probabilities # probabilities for known negatives
  recall <- sapply(
    probabilities,
    function(x) sum(pos_probs >= x) / pos
  )
  precision <- sapply(
    probabilities,
    function(x) sum(pos_probs >= x) / (sum(pos_probs >= x) + sum(neg_probs >= x))
  )
  if (is.null(model.name)) {
    result <- data.frame(precision, recall)
  } else {
    result <- data.frame(precision, recall, model.name)
  }

  result %>% arrange(recall, desc(precision))
}

# make a reduced iris data set that only contains virginica and versicolor species
iris.small <- filter(iris, Species %in% c("virginica", "versicolor"))

# fit a logistic regression model to the data
glm.out <- glm(Species ~ Petal.Width + Petal.Length + Sepal.Width,
  data = iris.small,
  family = binomial
)

# make a data frame with linear predictors from the model and true species assignment
lr_data <- data.frame(
  predictor = glm.out$linear.predictors,
  Species = iris.small$Species
)

# create a new data frame with linear predictors, species, and time
virg_t1 <- lr_data %>% filter(Species == "virginica") %>% mutate(predictor = predictor - 8.7, time = 1)
vers_t1 <- lr_data %>% filter(Species == "versicolor") %>% mutate(predictor = predictor + 8.8, time = 1)

# change predictor values and add `time` variable to respresent a state in an animation
# for each time point, changes in predictor values should match to the predictor values of the density plot
virg_t1 %>% mutate(predictor = mean(predictor) + 0.4 * (predictor - mean(predictor)), time = 2) -> virg_t2
vers_t1 %>% mutate(time = 2) -> vers_t2

# combine all data sets together
rbind(virg_t1, virg_t2, vers_t1, vers_t2) -> anim_data

# make an animation with distributions of linear predictors
p_dist <- ggplot(anim_data, mapping = aes(predictor, fill = Species)) +
  geom_density(alpha = 0.7, color = NA) +
  geom_hline(yintercept = 0, color = "black", size = 0.5, linetype = 2) +
  scale_x_continuous(limits = c(-45, 50)) +
  scale_fill_manual(values = c("#C04A56", "#3D8CF1")) +
  transition_states(time, transition_length = 1, state_length = 1) +
  ggtitle(" ") + # adding an emtpy title to align y axis with ROC plot
  theme_cowplot() +
  theme(legend.position = "none")

# calculate ROC curves and AUC values
anim_data %>%
  mutate(probabilities = exp(predictor) / (1 + exp(predictor))) %>% # calculate probabilities for linear predictors
  group_by(time) %>%
  do(results = calc_ROC(
    probabilities = .$probabilities, # calculate TP rate and FP rate for every possible cutoff
    known_truth = .$Species
  )) %>%
  group_by(time) %>%
  do(as.data.frame(.$results)) %>% # store output from calc_ROC() in the data frame
  mutate(delta = false_pos - lag(false_pos)) %>% # calculate AUC values
  mutate(AUC = sprintf("%.3f", sum(delta * true_pos, na.rm = T))) -> ROC

# calculate precision-recall curves
anim_data %>%
  mutate(probabilities = exp(predictor) / (1 + exp(predictor))) %>% # calculate probabilities for linear predictors
  group_by(time) %>%
  do(results = calc_PR(
    probabilities = .$probabilities, # calculate precision and recall
    known_truth = .$Species
  )) %>%
  group_by(time) %>%
  do(as.data.frame(.$results)) -> PR

# make an animation with ROC curves
p_ROC <- ggplot(data = ROC, aes(x = false_pos, y = true_pos)) +
  geom_line(size = 1) +
  geom_abline(intercept = 0, slope = 1) +
  transition_states(AUC, transition_length = 1, state_length = 1) +
  ggtitle("AUC = {closest_state}") +
  scale_x_continuous(name = "false positive rate") +
  scale_y_continuous(name = "true positive rate") +
  theme_cowplot()

# make an animation with precision-recall curves
p_PR <- ggplot(data = PR, aes(x = recall, y = precision)) +
  geom_line(size = 1) +
  transition_states(time, transition_length = 1, state_length = 1) +
  scale_x_continuous(limits = c(0, 1)) +
  scale_y_continuous(limits = c(0, 1)) +
  ggtitle(" ") + # adding an emtpy title to align y axis with ROC plot
  theme_cowplot()

# save each animation as individual frames
# each frame will be saved as a PNG image
p_dist_gif <- animate(p_dist,
  device = "png",
  width = 400,
  height = 400,
  renderer = file_renderer("../animations/gganim_SD", prefix = "p_dist", overwrite = TRUE)
)
p_ROC_gif <- animate(p_ROC,
  device = "png",
  width = 400,
  height = 400,
  renderer = file_renderer("../animations/gganim_SD", prefix = "p_ROC", overwrite = TRUE)
)
p_PR_gif <- animate(p_PR,
  device = "png",
  width = 400,
  height = 400,
  renderer = file_renderer("../animations/gganim_SD", prefix = "p_PR", overwrite = TRUE)
)

# stitch animations together
# read the first image (frame) of each animation
a <- image_read(p_dist_gif[[1]])
b <- image_read(p_ROC_gif[[1]])
c <- image_read(p_PR_gif[[1]])
# combine the two images into a single image
combined <- image_append(c(a, b, c))
new_gif <- c(combined)
for (i in 2:100) { # combine images frame by frame
  a <- image_read(p_dist_gif[[i]])
  b <- image_read(p_ROC_gif[[i]])
  c <- image_read(p_PR_gif[[i]])
  combined <- image_append(c(a, b, c))
  new_gif <- c(new_gif, combined)
}

# make an animation of the combined images
combined_gif <- image_animate(new_gif)
# save as gif
image_write(combined_gif, "../animations/SD.gif")


require(ggplot2) # for plotting
require(ggpubr) # for violin plots
require(gridExtra) # for combining plots
require(RColorBrewer) # to define color scales
require(ggrepel) # for plot labeling

# Plot Arctica islandica data and calibration

# ----------------Preparation for plot asthetics--------------------------------
# Prepare secondary temperature axis
temp_labs <- c("0", "5", rep("", 3), "25", rep("", 4), "50", rep("", 14), "125", rep("", 24), "250", rep("", 149), "1000")
temp_labs_lowT <- c(as.character(seq(0, 30 ,5)), "", "40", "", "50", "", "60", "", "70", "", "80", "", "90", "", "100", rep("", 4), "125", rep("", 24), "250", rep("", 149), "1000")
temp_breaks <- seq(0, 1000, 5)

# Build custom color scales for A. islandica plot
Ais_colorscale <- unlist(brewer.pal(length(unique(Aisstats$sample)), "RdBu"))
names(Ais_colorscale) <- unique(Aisstats$sample[order(Aisstats$Temp, decreasing = TRUE)])

Ais_plot <- ggplot(data = dat, aes(10^6 / (Temp + 273.15) ^ 2 , D47)) +
# Anderson and Meinicke calibration and York regressions
    geom_line(data = Anderson21,
        aes(x = Temp, y = D47),
        color = "black",
        linetype = "dashed",
        cex = 1,
        alpha = 1) +
    geom_line(data = MeinickeICDES[1:1001, ],
        aes(x = Temp, y = D47),
        color = "black",
        linetype = "dotted",
        cex = 1,
        alpha = 1) +
    geom_ribbon(data = Ais_York_result,
        aes(x = x,
        y = fit,
        ymin = lwr,
        ymax = upr),
        fill = "grey",
        alpha = 0.5) +
    geom_ribbon(data = Mollusk_York_result,
        aes(x = x,
        y = fit,
        ymin = lwr,
        ymax = upr),
        fill = "lightblue",
        alpha = 0.5) +
# Violin plots
    geom_violin(data = violin_data[which(!violin_data$outlier & violin_data$Analysis == "this study"), ],
        aes(10^6 / (Temp + 273.15) ^ 2,
            y = D47,
            fill = sample),
            kernel = "rectangular",
            scale = "area",
            position = "identity",
            width = .1,
            cex = 0,
            alpha = 0.1,
            color = NA,
            trim = FALSE,
            show.legend = FALSE) +
# Measurements
    geom_point(data = dat[which(!dat$D47_outlier & dat$Analysis == "this study"), ],
        aes(x = 10^6 / (Temp + 273.15) ^ 2,
            y = D47,
            color = sample),
        alpha = 0.2,
        cex = 1) +
    geom_point(data = dat[which(dat$ID == "A.islandica"), ],
        aes(x = 10^6 / (Temp + 273.15) ^ 2,
            y = D47,
            color = "Bernasconi18"),
        alpha = 0.2,
        cex = 1) +
    geom_pointrange(data = Aisstats,
        aes(x = 10^6 / (Temp + 273.15) ^ 2,
            y = D47_mean,
            ymin = D47_mean - CL95,
            ymax = D47_mean + CL95,
            color = sample),
        position = position_dodge2(width = .05),
        cex = 1,
        alpha = 0.2) +
    geom_text_repel(data = Aisstats,
        aes(x = 10^6 / (Temp + 273.15) ^ 2,
            y = D47_mean,
            color = sample),
        label = Aisstats$N[order(Aisstats$Temp, decreasing = TRUE)],
        position = position_dodge2(width = .05),
        box.padding = 0.5) +
# Aggregated sample data
    geom_errorbar(data = D47stats[which(D47stats$Analysis == "this study"), ],
        aes(x = 10^6 / (Temp + 273.15) ^ 2,
            y = D47_mean,
            ymin = D47_mean - CL95,
            ymax = D47_mean + CL95,
            color = sample),
        width = 0.05,
        cex = 1,
        alpha = 1) +
    geom_errorbar(data = D47stats[which(D47stats$ID == "A.islandica"), ],
        aes(x = 10^6 / (Temp + 273.15) ^ 2,
            y = D47_mean,
            ymin = D47_mean - CL95,
            ymax = D47_mean + CL95,
            color = "Bernasconi18"),
        width = 0.05,
        cex = 1,
        alpha = 1) +
# Plot layout
    ylim(0.55, max(Aisstats$D47_mean + Aisstats$CL95)) +
    scale_x_continuous(10^6/T^2~"(K)",
        limits = c(11.5, 13.5),
        breaks = seq(11, 14, 0.5),
        minor_breaks = seq(11, 14, 0.25),
        sec.axis = sec_axis(~ sqrt(1e6 / .) - 273.15,
            "Temperature (°C)",
            breaks = temp_breaks,
            labels = temp_labs_lowT)) +
    ggtitle(expression("Arctica islandica "~Delta[47]~" vs Temperature")) +
    labs(x = 10^6/T^2~"(K)",
        y = Delta*Delta[47]~"(\u2030"~"I-CDES)",
        colour = "Legend") +
    scale_colour_manual(values = Ais_colorscale) +
    scale_fill_manual(values = Ais_colorscale) +
    theme_bw() +
    theme(legend.position = "none")


###############################################################################
# Diagnostics for LM and GLM
#------------------------------------------------------------------------------
# based on http://rpubs.com/sinhrks/plot_pca
###############################################################################
# install.packages("ggplot2")
# install.packages('ggfortify')

#==============================================================================
# LIBRARY DEPENDENCE
#==============================================================================
library(ggplot2)
library(ggfortify)

#==============================================================================
# Plotting Diagnostics for Linear Models
#==============================================================================
mymodel <- lm(Petal.Width ~ Petal.Length
autoplot(mymodel, data = iris), label.size = 3)

par(mfrow = c(1, 2))
m <- lm(Petal.Width ~ Petal.Length, data = iris)
autoplot(m, which = 1:6, ncol = 3, label.size = 3)

#==============================================================================
# Plotting Diagnostics for Generalized Linear Models
#==============================================================================
# It also suppotgs glm instance.

m <- glm(Murder ~ Assault + UrbanPop + Rape,
         family = gaussian, data = USArrests)

autoplot(m, which = 1:6, label.size = 3)

#------------------------------------------------------------------------------
# Decorating Plots
#------------------------------------------------------------------------------
# Because {ggplot2} itself cannot handle different kinds of plots in a single instance, {ggfortify} handle them using its original class named  ggmultiplot. You can use + operator to decorate ggmultiplot.

class(autoplot(m))
autoplot(m, label.size = 3) + theme_bw()

#------------------------------------------------------------------------------
# Specifing Plotting Options
#------------------------------------------------------------------------------
# Some properties can be changed by passing corresponding keywords. For example, colour keyword is for data points, smooth.colour is for smoothing lines and ad.colour is for additional auxiliary lies. Also, ncol and nrow control facet layout. Use help(autoplot.lm) (or  help(autoplot.*) for any other objects) to check available options.

autoplot(m, which = 1:6, colour = 'dodgerblue3',
         smooth.colour = 'black', smooth.linetype = 'dashed',
         ad.colour = 'blue',
         label.size = 3, label.n = 5, label.colour = 'blue',
         ncol = 3)

# Also, you can use column names for these properties. Note that lm and glm instances doesn’t retain original data, you should pass original data via data keyword to use column names not included in the model.

autoplot(lm(Petal.Width ~ Petal.Length, data = iris), data = iris,
         colour = 'Species', label.size = 3)

Linear_Models/Diagnostics for LM and GLM.r


function (v)
{
    (v - mean(v, na.rm = T))/sqrt(var(v, na.rm = T))
}


#' Z-transform normalized, imputed metabolomics data
#'
#' @param data - Normalized, imputed data. Data matrix with observations as rows, features as columns.
#' @param ref - Reference samples normalized, imputed data.
#' @return zscore.data - Z-transformed data.
#' @export data.zscoreData
data.zscoreData = function(data, ref) {
  print("zscoreData() called.")

  # Only metabolites that also occur in the reference population can be z-scored
  data = data[which(rownames(data) %in% rownames(ref)),]
  ref = ref[which(rownames(ref) %in% rownames(data)),]
  data = data[sort(rownames(data)),]
  ref = ref[sort(rownames(ref)),]

  # Log transform data
  data = log(data)
  ref = log(data.matrix(ref))

  zscore.data = data
  for (met in 1:nrow(data)) {
    met_data = as.numeric(ref[met,])
    rmSamples = unique(c(which(is.na(met_data)), which(is.infinite(met_data))))
    if (length(rmSamples)>0) {
      x = met_data[-rmSamples]
    } else {
      x = met_data
    }
    if (all(is.na(x))) {

    } else {
      if (length(x[intersect(which(x>quantile(x, 0.025)), which(x<quantile(x, .975)))]) > 3) {
        x = x[intersect(which(x>quantile(x, 0.025)), which(x<quantile(x, .975)))]
      }
      d = qqnorm(x, plot.it = FALSE);
      x = as.numeric(d$y)
      z = as.numeric(d$x)
      df = data.frame(x=x,z=z)
      t = lm(x~z, data=df)
      mn.est = as.numeric(t$coefficients[1])
      sd.est = as.numeric(t$coefficients[2])
      rm(d,x,z,df,t)
      zscore.data[met,] = (data[met, ]-mn.est)/sd.est
    }
  }

  return(zscore.data)
}


library(stats)
library(forecast)
library(ggplot2)

#Strip data down to a single column, no label.

snap <- read.csv("xxx.csv")
crackle <- findfrequency(snap)
  #used to determine the frequency/period for seasonality.
pop <- ts(crackle, frequency=30)
  #frequency here marks the period. 12 for months in a year, 4 for quarters in a year, 30 for days in a month. There must be at least two full periods in the data based on the chosen frequency, or there will be an error. Adjust in accord with the preceding "findfrequency" function.
plot(decompose(pop)
  #this will create four graphs: 1 of the original data, three decomposed showing the trendline, seasonal swings, and the extracted "noise" from the former.

tick <- auto.arima(crackle, d=NA, D=NA, max.p=5, max.q=5,
              max.P=2, max.Q=2, max.order=5, max.d=2, max.D=1,
              start.p=2, start.q=2, start.P=1, start.Q=1,
              stationary=FALSE, seasonal=TRUE,
              ic=c("aicc", "aic", "bic"), stepwise=TRUE, trace=FALSE,
              approximation=(length(crackle)>100 | frequency(crackle)>12), xreg=NULL,
              test=c("kpss","adf","pp"), seasonal.test=c("ocsb","ch"),
              allowdrift=TRUE, allowmean=TRUE, lambda=NULL, biasadj=FALSE,
              parallel=FALSE, num.cores=2)
  #Auto ARIMA will automatically seek out the best model based on AIC, etc. Note three places here where the arguments need to be edited for the name of the times series variable.

plot(forecast(tick))


#' @name MGB2
#' @rdname  MGB2
#' @aliases dMGB2  pMGB2  hMGB2
#' @title Bivarite MGB2 copula
#' @description Density, distribution function, and h-functions for the bivariate MGB2 copula proposed in Yang et al.,(2011).
#' @param u1,u2 numeric vectors of equal length with values in \eqn{[0,1]}.
#' @param pars1,pars2,pars3 copula parameters, denoted by \eqn{p_1, p_2, q}.
#' @importFrom stats qbeta
#' @importFrom stats pbeta
#' @references Xipei Yang, Edward W Frees, and Zhengjun Zhang. A generalized beta copula with applications in
#' modeling multivariate long-tailed data. Insurance: Mathematics and Economics, 49(2):265-284, 2011.
#' @details
#' The MGB2 copula with parameters (p1, p2, q) has joint density
#' 		\deqn{c(u_1,u_2;p_1,p_2,q)=\frac{\Gamma(q)\Gamma(\sum_{i=1}^2 p_i + q)}{\prod_{i=1}^2\Gamma(p_i+q)}\frac{\prod_{i=1}^2 (1 + x(u_i;p_i,q))^{p_i+q}}{(1 + \sum_{i=1}^{2}x(u_i;p_i,q))^{\sum_{i=1}^{2}p_i+q}},}
#' for \eqn{p_1, p_2>0, q>0}.
#' (Here Gamma(a) is the function implemented by R's \code{\link[base]{gamma}} and defined in its help.
#'
#'
#' The joint cdf of the MGB2 copula is
#'
#' \deqn{C(u_1,u_2;p_1,p_2,q)=\int_{0}^{+\infty}\prod_{i=1}^{2}G_p(\frac{I_{p_i,q}^{-1}(u_i)}{(1-I_{p_i,q}^{-1}(u_i))\theta})\times \frac{\theta^{-(q+1)}e^{-1/\theta}}{\Gamma(q)}d\theta, }
#' where \eqn{I_{m,n}^{-1}()} denotes the inverse of the beta cumulative distribution function (or regularized incomplete beta function)
#' with parameters shape1 = m and shape2 = n
#' implemented by R's \code{\link[stats]{qbeta}}.
#'
#' The h-function is defined as the conditional distribution function of a bivariate copula, i.e.,
#' \deqn{h_1(u_2|u_1,p_1,p_2,q) := P(U_2 \leq u_2 | U_1 = u_1) = \partial C(u_1,u_2) / \partial u_1,}
#'
#' \deqn{h_2(u_1|u_2,p_1,p_2,q) := P(U_1 \leq u_1 | U_2 = u_2) := \partial C(u_1,u_2) / \partial u_2,}
#'
#' where \eqn{(U_1, U_2) \sim C}, and \eqn{C} is a bivariate copula distribution function with parameter(s) \eqn{p_1,p_2,q}.
#'
#'
#' @return
#' \code{dcMGB2.bivar} gives the density
#'
#' \code{pcMGB2.bivar} gives the distribution function
#'
#' \code{hcMGB2.bivar} gives the h-functions (hfunc1, hfunc2).
NULL

#' @rdname  MGB2
#' @export
#' @examples
#' dcMGB2.bivar(u1 = c(0.2, 0.5), u2 = c(0.9, 0.2), pars1 = 0.5, pars2 = 0.5, pars3 = 1.5)
dcMGB2.bivar <- function(u1, u2, pars1, pars2, pars3) {
  dim <- 2
  p1 <- pars1
  p2 <- pars2
  q <- pars3

  x1 <- qbeta(u1, shape1 = p1, shape2 = q) / (1 - qbeta(u1, shape1 = p1, shape2 = q))
  x2 <- qbeta(u2, shape1 = p2, shape2 = q) / (1 - qbeta(u2, shape1 = p2, shape2 = q))

  if (u1 == 0 | u2 == 0) {
    dc <- 0
  } else {
    dc <- gamma(q)^(dim - 1) * gamma(p1 + p2 + q) / (gamma(p1 + q) * gamma(p2 + q)) * (1 + x1)^(p1 + q) * (1 + x2)^(p2 + q) / (1 + x1 + x2)^(p1 + p2 + q)
  }
  dc
}
dcMGB2.bivar <- Vectorize(dcMGB2.bivar)

#' @rdname MGB2
#' @export
#' @examples
#' pcMGB2.bivar(u1 = c(0.5, 0.1), u2 = c(0.9, 0.1), pars1 = 0.5, pars2 = 0.5, pars3 = 1.5)
pcMGB2.bivar <- function(u1, u2, pars1, pars2, pars3) {
  p1 <- pars1
  p2 <- pars2
  q <- pars3

  x1 <- qbeta(u1, shape1 = p1, shape2 = q) / (1 - qbeta(u1, shape1 = p1, shape2 = q))
  x2 <- qbeta(u2, shape1 = p2, shape2 = q) / (1 - qbeta(u2, shape1 = p2, shape2 = q))
  fin <- function(theta) { # rely on a
    m1 <- x1 / theta
    m2 <- x2 / theta
    z1 <- pgamma(m1, shape = p1, scale = 1) * pgamma(m2, shape = p2, scale = 1)
    out <- z1 * theta^(-(q + 1)) * exp(-1 / theta) / gamma(q)
    out
  }
  if (u1 == 0 | u2 == 0) {
    z <- 0
  } else {
    z <- as.numeric(pracma::integral(fun = fin, xmin = 0, xmax = Inf, method = "Clenshaw"))
    # z <- as.numeric(integrate(f = fin, lower = 0, upper = Inf, rel.tol = 1e-4)$value)
  }
  return(z) # rely on k
}
pcMGB2.bivar <- Vectorize(pcMGB2.bivar)

#' @rdname MGB2
#' @export
#' @examples
#' hcMGB2.bivar(u1 = c(0.5, 0.1), u2 = c(0.9, 0.1), pars1 = 0.5, pars2 = 0.5, pars3 = 1.5)$hfunc1
#' hcMGB2.bivar(u1 = c(0.5, 0.1), u2 = c(0.9, 0.1), pars1 = 0.5, pars2 = 0.5, pars3 = 1.5)$hfunc2
hcMGB2.bivar <- function(u1, u2, pars1, pars2, pars3) {
  p1 <- pars1
  p2 <- pars2
  q <- pars3

  x1 <- qbeta(u1, shape1 = p1, shape2 = q) / (1 - qbeta(u1, shape1 = p1, shape2 = q))
  x2 <- qbeta(u2, shape1 = p2, shape2 = q) / (1 - qbeta(u2, shape1 = p2, shape2 = q))

  index1 <- u1 == 1 & u2 != 1
  index2 <- u1 != 1 & u2 == 1
  index3 <- u1 == 1 & u2 == 1
  z1 <- x2 / (x1 + x2 + 1)
  z2 <- x1 / (x2 + x1 + 1)
  z1[index1] <- 0
  z2[index1] <- 1
  z1[index2] <- 1
  z2[index2] <- 0
  z1[index3] <- 1
  z2[index3] <- 1
  hfunc1 <- pbeta(z1, shape1 = p2, shape2 = p1 + q)
  hfunc2 <- pbeta(z2, shape1 = p1, shape2 = p2 + q)
  list(hfunc1 = hfunc1, hfunc2 = hfunc2)
}


fib <- function(n) {
  if(n <= 1) { return(1) }
  return(fib(n-1) + fib(n-2))
}

print( fib(46) )


## A slightly modified version of the function
## DoISVA from the ISVA R package.
## https://cran.r-project.org/web/packages/isva/

## require(fastICA)

isva <- function(data.m,mod,pvthCF=0.01,th=0.05,ncomp=NULL,
                   verbose=F){

    stopifnot(is.matrix(data.m))
    isva.o <- isvaFn(data.m,mod,ncomp,verbose=verbose);
    selisv.idx <- 1:ncol(isva.o$isv);
    selisv.m <- matrix(isva.o$isv[,selisv.idx],ncol=length(selisv.idx));
    return(list(isv=selisv.m,nsv=length(selisv.idx),selisv=selisv.idx));
}

EstDimRMT <- function(data.m,plot=TRUE,verbose=F){
    ## standardise matrix
    M <- apply(data.m,2,function(X){ (X - mean(X))/sqrt(var(X))});

    sigma2 <- var(as.vector(M));
    Q <- nrow(data.m)/ncol(data.m);
    ns <- ncol(data.m);
    lambdaMAX <- sigma2*(1+1/Q + 2*sqrt(1/Q));
    lambdaMIN <- sigma2*(1+1/Q - 2*sqrt(1/Q));
    delta <- lambdaMAX - lambdaMIN;#  print(delta);

    roundN <- 3;
    step <- round(delta/ns,roundN);
    while(step==0){
        roundN <- roundN+1;
        step <- round(delta/ns,roundN);
    }

    lambda.v <- seq(lambdaMIN,lambdaMAX,by=step);
    dens.v <- vector();
    ii <- 1;
    for(i in lambda.v){
        dens.v[ii] <- (Q/(2*pi*sigma2))*sqrt( (lambdaMAX-i)*(i-lambdaMIN) )/i;
        ii <- ii+1;
    }
    ## theoretical density
    thdens.o <- list(min=lambdaMIN,max=lambdaMAX,step=step,lambda=lambda.v,dens=dens.v);
    C <- 1/nrow(M) * t(M) %*% M;
    eigen.o <- eigen(C,symmetric=TRUE);
    ## empirical density
    estdens.o <- density(eigen.o$values,from=min(eigen.o$values),to=max(eigen.o$values),cut=0);
    intdim <- length(which(eigen.o$values > thdens.o$max));
    return(list(cor=C,dim=intdim,estdens=estdens.o,thdens=thdens.o,evals=eigen.o$values));
}

isvaFn <- function(data.m,mod,ncomp=NULL,verbose=F){
## isvaFn <- function(data.m,pheno.v,ncomp=NULL,verbose=F){
    ##lm.o <- lm(t(data.m) ~ pheno.v);
    ##res.m <- t(lm.o$res)

    ## BEGIN NEW
    id <- diag(ncol(data.m))
    res.m <- data.m %*% (id - mod %*% solve(t(mod) %*% mod) %*% t(mod))
    ## END NEW

    ## model <- model.matrix(~1+pheno.v); ## 'model' never used!
    if(is.null(ncomp)){
        rmt.o <-  EstDimRMT(res.m, verbose=verbose)
        ncomp <- rmt.o$dim;
        msg(paste("Number of candidate ISVs = ",ncomp,sep=""), verbose=verbose);
    }
    else {
        msg("no need to estimate dimensionality", verbose=verbose);
    }

    ## perform ICA on residual matrix
    fICA.o <- fastICA(res.m,n.comp=ncomp);

    ## now construct ISV
    tmp.m <- t(fICA.o$A);
    isv.m <- tmp.m;
    sd <- 1/sqrt(ncol(data.m)-3);
    for(k in 1:ncol(tmp.m)){
        cor.v <- as.vector(cor(t(data.m),tmp.m[, k]))
        z.v <- 0.5*log((1+cor.v)/(1-cor.v));
        pv.v <- 2*pnorm(abs(z.v),0,sd,lower.tail=FALSE)
        tmp.s <- sort(pv.v,decreasing=FALSE,index.return=TRUE);
        ##qv.o <- qvalue(pv.v);
        ##nsig <- length(which(qv.o$qvalues<0.05));
### BEGIN NEW
        qv.o <- p.adjust(pv.v, "fdr")
        nsig <- length(which(qv.o < 0.05))
### END NEW
        if( nsig < 500 ){
            nsig <- 500;
        }
        red.m <- data.m[tmp.s$ix[1:nsig],];
        fICA.o <- fastICA(red.m,n.comp=ncomp);
        cor.v <- abs(cor(tmp.m[,k],t(fICA.o$A)));
        kmax <- which.max(cor.v);
        isv.m[,k] <- t(fICA.o$A)[,kmax];
        msg(paste("Built ISV ",k,sep=""), verbose=verbose);
    }
    return(list(n.isv=ncomp,isv=isv.m));
}


# Exmaple taken from http://www.petrkeil.com/?p=1709

# Load required libraries
library(sp)
library(raster)

# Set environment variables
DATADIR <- "../../data"

# Load data
load(file.path(DATADIR, "bei.rda"))

# Visualize tree locations
plot(
  bei$x,
  bei$y,
  pch=20,
  cex=0.5,
  col="darkgreen",
  main="Location of trees in the 50-ha Barro Colorado plot",
  xlab="x coordinate (m)",
  ylab="y coordinate (m)",
  frame=FALSE
)

# Define elevation and gradient predictors
elevation <- raster(bei.extra[[1]])
gradient <- raster(bei.extra[[2]])

# Crop the predictors so that they have exactly 500 x 1000 cells
ext <- extent(2.5, 1002.5, 2.5, 1002.5)
elevation <- crop(elevation, ext)
gradient <- crop(gradient, ext)

# Create coarse grid of predictors into 50 x 50 m grid by taking the mean of the 5 x 5 m grid cells
elevation50 <- aggregate(elevation, fact=10, fun=mean)
gradient50 <- aggregate(gradient, fact=10, fun=mean)

# Fit spatial data into the 50 x 50 m grid
xy <- data.frame(x = bei$x, y = bei$y)

# Create coarse response
# The following two vectors coincide:
# rasterize(xy, gradient50, fun = "count")[]
# rasterize(xy, gradient50, fun = "count")[]
n50 <- rasterize(xy, elevation50, fun="count")
n50[is.na(n50)] <- 0 # Replace NA values by 0

# Visualization of coarse data
plot(elevation50, main="Predictor: mean elevation in 50x50 m cells")
plot(gradient50, main="Predictor: mean gradient in 50x50 m cells")
plot(n50, main="Response: # of Individuals in 50x50 m cells")

# Standardize predictors
standardize <- function(x) {
  (x - mean(x))/sd(x)
}

sdelevation50 <- standardize(elevation50[])

sdgradient50 <- standardize(gradient50[])

sqsdelevation50 <- sdgradient50^2

# Run Poisson regression
poissonreg <- glm(n50[] ~ sdelevation50+sqsdelevation50+sdgradient50, family="poisson")

summary(poissonreg)

write.csv(
  data.frame(
    n50=n50[],
    elevation50=elevation50[],
    gradient50=gradient50[]
  ),
  file=file.path(DATADIR, "coarse_bei.csv"),
  quote=FALSE,
  row.names=FALSE
)


# Goal: To show amazing R indexing notation, and the use of is.na()

x <- c(2,7,9,2,NA,5)                 # An example vector to play with.

# Give me elems 1 to 3 --
x[1:3]

# Give me all but elem 1 --
x[-1]

# Odd numbered elements --
indexes <- seq(1,6,2)
x[indexes]
# or, more compactly,
x[seq(1,6,2)]

# Access elements by specifying "on" / "off" through booleans --
require <- c(TRUE,TRUE,FALSE,FALSE,FALSE,FALSE)
x[require]
# Short vectors get reused! So, to get odd numbered elems --
x[c(TRUE,FALSE)]

# Locate missing data --
is.na(x)

# Replace missing data by 0 --
x[is.na(x)] <- 0
x

# Similar ideas work for matrices --
y <- matrix(c(2,7,9,2,NA,5), nrow=2)
y

# Make a matrix containing columns 1 and 3 --
y[,c(1,3)]

# Let us see what is.na(y) does --
is.na(y)
str(is.na(y))
# So is.na(y) gives back a matrix with the identical structure as that of y.
# Hence I can say
y[is.na(y)] <- -1
y

RFrontEndSolution/Tests Repo/Rscripts All (163 files)/b6.r


# Chapter 8 Lab: Decision Trees

# Fitting Classification Trees

library(tree)
library(ISLR)
attach(Carseats)
High=ifelse(Sales<=8,"No","Yes")
Carseats=data.frame(Carseats,High)
tree.carseats=tree(High~.-Sales,Carseats)
summary(tree.carseats)
plot(tree.carseats)
text(tree.carseats,pretty=0)
tree.carseats
set.seed(2)
train=sample(1:nrow(Carseats), 200)
Carseats.test=Carseats[-train,]
High.test=High[-train]
tree.carseats=tree(High~.-Sales,Carseats,subset=train)
tree.pred=predict(tree.carseats,Carseats.test,type="class")
table(tree.pred,High.test)
(86+57)/200
set.seed(3)
cv.carseats=cv.tree(tree.carseats,FUN=prune.misclass)
names(cv.carseats)
cv.carseats
par(mfrow=c(1,2))
plot(cv.carseats$size,cv.carseats$dev,type="b")
plot(cv.carseats$k,cv.carseats$dev,type="b")
prune.carseats=prune.misclass(tree.carseats,best=9)
plot(prune.carseats)
text(prune.carseats,pretty=0)
tree.pred=predict(prune.carseats,Carseats.test,type="class")
table(tree.pred,High.test)
(94+60)/200
prune.carseats=prune.misclass(tree.carseats,best=15)
plot(prune.carseats)
text(prune.carseats,pretty=0)
tree.pred=predict(prune.carseats,Carseats.test,type="class")
table(tree.pred,High.test)
(86+62)/200

# Fitting Regression Trees

library(MASS)
set.seed(1)
train = sample(1:nrow(Boston), nrow(Boston)/2)
tree.boston=tree(medv~.,Boston,subset=train)
summary(tree.boston)
plot(tree.boston)
text(tree.boston,pretty=0)
cv.boston=cv.tree(tree.boston)
plot(cv.boston$size,cv.boston$dev,type='b')
prune.boston=prune.tree(tree.boston,best=5)
plot(prune.boston)
text(prune.boston,pretty=0)
yhat=predict(tree.boston,newdata=Boston[-train,])
boston.test=Boston[-train,"medv"]
plot(yhat,boston.test)
abline(0,1)
mean((yhat-boston.test)^2)

# Bagging and Random Forests

library(randomForest)
set.seed(1)
bag.boston=randomForest(medv~.,data=Boston,subset=train,mtry=13,importance=TRUE)
bag.boston
yhat.bag = predict(bag.boston,newdata=Boston[-train,])
plot(yhat.bag, boston.test)
abline(0,1)
mean((yhat.bag-boston.test)^2)
bag.boston=randomForest(medv~.,data=Boston,subset=train,mtry=13,ntree=25)
yhat.bag = predict(bag.boston,newdata=Boston[-train,])
mean((yhat.bag-boston.test)^2)
set.seed(1)
rf.boston=randomForest(medv~.,data=Boston,subset=train,mtry=6,importance=TRUE)
yhat.rf = predict(rf.boston,newdata=Boston[-train,])
mean((yhat.rf-boston.test)^2)
importance(rf.boston)
varImpPlot(rf.boston)

# Boosting

library(gbm)
set.seed(1)
boost.boston=gbm(medv~.,data=Boston[train,],distribution="gaussian",n.trees=5000,interaction.depth=4)
summary(boost.boston)
par(mfrow=c(1,2))
plot(boost.boston,i="rm")
plot(boost.boston,i="lstat")
yhat.boost=predict(boost.boston,newdata=Boston[-train,],n.trees=5000)
mean((yhat.boost-boston.test)^2)
boost.boston=gbm(medv~.,data=Boston[train,],distribution="gaussian",n.trees=5000,interaction.depth=4,shrinkage=0.2,verbose=F)
yhat.boost=predict(boost.boston,newdata=Boston[-train,],n.trees=5000)
mean((yhat.boost-boston.test)^2)


#' QR
#'
#' QR factorization and related functions.
#'
#' @details
#' The factorization is performed by the LAPACK routine \code{sgeqp3()}. This
#' should be similar to calling \code{qr()} on an ordinary R matrix with the
#' argument \code{LAPACK=TRUE}. Calling \code{qr(x, LAPACK=FALSE)} on a double
#' precision matrix 'x' (the default) will not be comparable in performance (it
#' is much slower) or numerics to calling \code{qr(s)} where 's' is single a
#' float matrix.
#'
#' @param x
#' A float matrix.
#' @param y
#' A vector/matrix or right hand sides (int, float, or double).
#' @param tol
#' The tolerance for determining numerical column rank.
#' @param ...
#' Ignored.
#' @param qr
#' Output of \code{qr()}.
#' @param complete
#' Should the complete or truncated factor be returned?
#' @param Dvec
#' Vector of diagonals to use when re-constructing Q (default is 1's).
#'
#' @examples
#' library(float)
#'
#' x = flrunif(10, 3)
#' qr(x)
#'
#' @useDynLib float R_qr_spm R_qrQ_spm R_qrR_spm R_qrqy_spm
#' @name qr
#' @rdname qr
NULL

qr_float32 = function(x, tol=1e-7, ...)
{
  ret = .Call(R_qr_spm, DATA(x), tol)
  ret$qr = float32(ret$qr)
  ret$qraux = float32(ret$qraux)

  ret
}

qrQ_float32 = function(qr, complete=FALSE, Dvec)
{
  if (!is.qr(qr))
    stop("argument is not a QR decomposition")

  m = NROW(qr$qr)
  n = NCOL(qr$qr)

  if (is.float(qr$qr))
  {
    # ret = .Call(R_qrQ_spm, qr$DATA(qr), qr$DATA(qraux))
    if (missing(Dvec))
    {
      ret = .Call(R_qrQ_spm, DATA(qr$qr), DATA(qr$qraux), complete)
      float32(ret)
    }
    else
    {
      if (is.integer(Dvec))
      {
        Dvec = fl(Dvec)
        if (complete)
          RHS = diag(Dvec, m, m)
        else
          RHS = diag(Dvec[1:m], m, min(m, n))
      }
      else if (is.double(Dvec))
      {
        qr$qr = dbl(qr$qr)
        return(base::qr.Q(qr, complete, Dvec))
      }

      qrqy_float32(qr, RHS)
    }
  }
  else
  {
    if (!missing(Dvec) && is.float(Dvec))
      Dvec = dbl(Dvec)

    base::qr.Q(qr, complete, Dvec)
  }
}

qrR_float32 = function(qr, complete=FALSE)
{
  if (!is.qr(qr))
    stop("argument is not a QR decomposition")

  if (is.float(qr$qr))
  {
    ret = .Call(R_qrR_spm, DATA(qr$qr), as.logical(complete))
    float32(ret)
  }
  else
    base::qr.R(qr, complete)
}

qrqy = function(qr, y, trans)
{
  if (!is.qr(qr))
    stop("argument is not a QR decomposition")

  if (NROW(y) != NROW(qr$qr))
    stop("'qr' and 'y' must have the same number of rows")

  if (is.float(qr$qr))
  {
    if (is.integer(y))
      y = fl(y)
    else if (is.double(y))
    {
      qr$qr = dbl(qr$qr)
      qr$qraux = dbl(qr$qraux)
      return(base::qr.qy(qr, y))
    }
    else if (!is.float(y))
      stop("argument 'y' must be atomic")

    ret = .Call(R_qrqy_spm, DATA(qr$qr), DATA(qr$qraux), DATA(y), trans)
    float32(ret)
  }
  else
  {
    if (is.float(y))
      y = dbl(y)

    base::qr.qy(qr, y)
  }
}

qrqy_float32 = function(qr, y)
{
  qrqy(qr, y, FALSE)
}

qrtqy_float32 = function(qr, y)
{
  qrqy(qr, y, TRUE)
}

#' @rdname qr
#' @export
setMethod("qr", signature(x="float32"), qr_float32)

#' @rdname qr
#' @export
setMethod("qr.Q", signature(qr="ANY"), qrQ_float32)

#' @rdname qr
#' @export
setMethod("qr.R", signature(qr="ANY"), qrR_float32)

#' @rdname qr
#' @export
setMethod("qr.qy", signature(qr="ANY"), qrqy_float32)

#' @rdname qr
#' @export
setMethod("qr.qty", signature(qr="ANY"), qrtqy_float32)


## ----echo=FALSE---------------------------------------------------------------
require(Hmisc)
knitrSet('support')

## ----results='asis'-----------------------------------------------------------
require(rms)
options(prType='latex')    # for print, summary, anova
getHdata(support)          # Get data frame from web site
acute <- support$dzclass %in% c('ARF/MOSF','Coma')
latex(describe(support[acute,]), file='')

## ----naclus,w=7,h=5,ps=11,cap='Cluster analysis showing which predictors tend to be missing on the same patients',scap='Cluster analysis of missingness in SUPPORT'----
plot(naclus(support[acute,]))      # Figure (*\ref{fig:support-naclus}*)

## ----varclus,w=6.7,cap='Hierarchical clustering of potential predictors using Hoeffding $D$ as a similarity measure.  Categorical predictors are automatically expanded into dummy variables.',scap='Clustering of predictors in SUPPORT using Hoeffding $D$'----
ac <- support[acute,]
ac$dzgroup <- ac$dzgroup[drop=TRUE]    # Remove unused levels
label(ac$dzgroup) <- 'Disease Group'
attach(ac)
vc <- varclus(~ age + sex + dzgroup + num.co + edu + income +
              scoma + race + meanbp + wblc + hrt + resp +
              temp + pafi + alb + bili + crea + sod + ph +
              glucose + bun + urine + adlsc, sim='hoeffding')
plot(vc)                           # Figure (*\ref{fig:support-varclus}*)

## ----nikm,cap='$\\Phi^{-1}(S_{KM}(t))$ stratified by \\co{dzgroup}.  Linearity and semi-\\index{hypothesis test!equal slopes}parallelism indicate a reasonable fit to the log-normal accelerated failure time model with respect to one predictor.',scap='$\\Phi^{-1}(S_{KM}(t))$ stratified by \\co{dzgroup}'----
dd <- datadist(ac)
# describe distributions of variables to rms
options(datadist='dd')

# Generate right-censored survival time variable
years <- d.time/365.25
units(years) <- 'Year'
S <- Surv(years, death)

# Show normal inverse Kaplan-Meier estimates
# stratified by dzgroup
survplot(npsurv(S ~ dzgroup), conf='none',
         fun=qnorm,logt=TRUE)   # Figure (*\ref{fig:support-nikm}*)

## ----lognorm-resid, w=5.5, h=4, ps=7, lwd=1, top=2, mfrow=c(2,2), cap='Kaplan-Meier estimates of distributions of normalized, right-censored residuals from the fitted log-normal survival model.  Residuals are stratified by important variables in the model (by quartiles of continuous variables), plus a random variable to depict the natural variability (in the lower right plot).  Theoretical standard Gaussian distributions of residuals are shown with a thick solid line.',scap='Distributions of residuals from log-normal model'----
f <- psm(S ~ dzgroup + rcs(age,5) + rcs(meanbp,5),
         dist='lognormal', y=TRUE)
r <- resid(f)

survplot(r, dzgroup, label.curve=FALSE)
survplot(r, age,     label.curve=FALSE)
survplot(r, meanbp,  label.curve=FALSE)
random <- runif(length(age)); label(random) <- 'Random Number'
survplot(r, random, label.curve=FALSE)  # Fig. (*\ref{fig:support-lognorm-resid}*)

## ----spearman, w=4.5, top=1, ps=10, rt=3, cap='Generalized Spearman $\\rho^2$ rank correlation between predictors and truncated survival time'----
shortest.follow.up <- min(d.time[death==0], na.rm=TRUE)
d.timet <- pmin(d.time, shortest.follow.up)

w <- spearman2(d.timet ~ age + num.co + scoma + meanbp +
             hrt + resp + temp + crea + sod + adlsc +
             wblc + pafi + ph + dzgroup + race, p=2)
plot(w, main='')        # Figure (*\ref{fig:support-spearman}*)

## ----rcorrcens, w=4.5, top=1, ps=10, rt=3, cap="Somers' $D_{xy}$ rank correlation between predictors and original survival time.  For \\co{dzgroup} or \\co{race}, the correlation coefficient is the maximum correlation from using a dummy variable to represent the most frequent or one to represent the second most frequent category.',scap='Somers' $D_{xy}$ rank correlation between predictors and original survival time"----
w <- rcorrcens(S ~ age + num.co + scoma + meanbp + hrt + resp +
               temp + crea + sod + adlsc + wblc + pafi + ph +
               dzgroup + race)
plot(w, main='')          # Figure (*\ref{fig:support-rcorrcens}*)

## -----------------------------------------------------------------------------
# Compute number of missing values per variable
sapply(llist(age,num.co,scoma,meanbp,hrt,resp,temp,crea,sod,
             adlsc,wblc,pafi,ph), function(x) sum(is.na(x)))
# Can also do naplot(naclus(support[acute,]))
# Can also use the Hmisc naclus and naplot functions
# Impute missing values with normal or modal values
wblc.i <- impute(wblc, 9)
pafi.i <- impute(pafi, 333.3)
ph.i   <- impute(ph,   7.4)
race2  <- race
levels(race2) <- list(white='white',other=levels(race)[-1])
race2[is.na(race2)] <- 'white'
dd <- datadist(dd, wblc.i, pafi.i, ph.i, race2)

## -----------------------------------------------------------------------------
redun(~ crea + age + sex + dzgroup + num.co + scoma + adlsc +
      race2 + meanbp + hrt + resp + temp + sod + wblc.i +
      pafi.i + ph.i, nk=4)

## ----anovaSat,cap='Partial $\\chi^{2}$ statistics for association of each predictor with response from saturated main effects model, penalized for d.f.',scap='Partial $\\chi^{2}$ statistics from saturated main effects model'----
k <- 4
f <- psm(S ~ rcs(age,k)+sex+dzgroup+pol(num.co,2)+scoma+
         pol(adlsc,2)+race+rcs(meanbp,k)+rcs(hrt,k)+
         rcs(resp,k)+rcs(temp,k)+rcs(crea,3)+rcs(sod,k)+
         rcs(wblc.i,k)+rcs(pafi.i,k), dist='lognormal')
plot(anova(f))   # Figure (*\ref{fig:support-anovaSat}*)

## ----results='asis'-----------------------------------------------------------
f <- psm(S ~ rcs(age,5)+sex+dzgroup+num.co+
             scoma+pol(adlsc,2)+race2+rcs(meanbp,5)+
             rcs(hrt,3)+rcs(resp,3)+temp+
             rcs(crea,4)+sod+rcs(wblc.i,3)+rcs(pafi.i,4),
         dist='lognormal')
print(f, coefs=FALSE)
a <- anova(f)

## ----plot, h=7, w=7, cap='Effect of each predictor on log survival time.  Predicted values have been centered so that predictions at predictor reference values are zero.  Pointwise 0.95 confidence bands are also shown.  As all $y$-axes have the same scale, it is easy to see which predictors are strongest.',scap='Effect of predictors on log survival time in SUPPORT'----
ggplot(Predict(f, ref.zero=TRUE), vnames='names',
       sepdiscrete='vertical', anova=a)  # Figure (*\ref{fig:support-plot}*)

## ----results='asis'-----------------------------------------------------------
print(a, size='tsz')

## ----anova,cap='Contribution of variables in predicting survival time in log-normal model'----
plot(a)            # Figure (*\ref{fig:support-anova}*)

## ----summary, w=6.5, h=3.5, top=1, ps=11, cap='Estimated survival time ratios for default settings of predictors.  For example, when age changes from its lower quartile to the upper quartile (47.9y to 74.5y), median survival time decreases by more than half.  Different shaded areas of bars indicate different confidence levels (.9, 0.95, 0.99).',scap='Survival time ratios from fitted log-normal model'----
options(digits=3)
plot(summary(f), log=TRUE, main='')   # Figure (*\ref{fig:support-summary}*)

## ----results='asis',cache=TRUE------------------------------------------------
# First add data to model fit so bootstrap can re-sample
#  from the data
g <- update(f, x=TRUE, y=TRUE)
set.seed(717)
latex(validate(g, B=300), digits=2, size='Ssize')

## ----cal, cache=TRUE, cap='Bootstrap validation of calibration curve.  Dots represent apparent calibration accuracy; $\\times$ are bootstrap estimates corrected for overfitting, based on binning predicted survival probabilities and and computing Kaplan-Meier estimates.  Black curve is the estimated observed relationship using \\co{hare} and the blue curve is the overfitting-corrected \\co{hare} estimate.  The gray-scale line depicts the ideal relationship.',scap='Bootstrap validation of calibration curve for log-normal model'----
set.seed(717)
cal <- calibrate(g, u=1, B=300)
plot(cal, subtitles=FALSE)
cal <- calibrate(g, cmethod='KM', u=1, m=60, B=120, pr=FALSE)
plot(cal, add=TRUE)     # Figure (*\ref{fig:support-cal}*)

## -----------------------------------------------------------------------------
Z <- predict(f)    # X*beta hat
a <- ols(Z ~ rcs(age,5)+sex+dzgroup+num.co+
             scoma+pol(adlsc,2)+race2+
             rcs(meanbp,5)+rcs(hrt,3)+rcs(resp,3)+
             temp+rcs(crea,4)+sod+rcs(wblc.i,3)+
             rcs(pafi.i,4), sigma=1)
# sigma=1 is used to prevent sigma hat from being zero when
# R2=1.0 since we start out by approximating Z with all
#  component variables
fastbw(a, aics=10000)    # fast backward stepdown

## -----------------------------------------------------------------------------
f.approx <- ols(Z ~ dzgroup + rcs(meanbp,5) + rcs(crea,4) +
                rcs(age,5) + rcs(hrt,3) + scoma +
                rcs(pafi.i,4) + pol(adlsc,2)+
                rcs(resp,3), x=TRUE)
f.approx$stats

## -----------------------------------------------------------------------------
V <- vcov(f,regcoef.only=TRUE)      # var(full model)
X <- cbind(Intercept=1, g$x)        # full model design
x <- cbind(Intercept=1, f.approx$x) # approx. model design
w <- solve(t(x) %*% x, t(x)) %*% X  # contrast matrix
v <- w %*% V %*% t(w)

## -----------------------------------------------------------------------------
f.sub <- psm(S ~ dzgroup + rcs(meanbp,5) + rcs(crea,4) +
             rcs(age,5) + rcs(hrt,3) + scoma + rcs(pafi.i,4) +
             pol(adlsc,2)+ rcs(resp,3), dist='lognormal')

diag(v)/diag(vcov(f.sub,regcoef.only=TRUE))
r <- diag(v)/diag(vcov(f.sub,regcoef.only=TRUE))
r[c(which.min(r), which.max(r))]

## ----results='asis'-----------------------------------------------------------
f.approx$var <- v
print(anova(f.approx, test='Chisq', ss=FALSE), size='tsz')

## ----results='asis'-----------------------------------------------------------
# Typeset mathematical form of approximate model
latex(f.approx)

## ----results='asis'-----------------------------------------------------------
# Derive S functions that express mean and quantiles
# of survival time for specific linear predictors
# analytically
expected.surv <- Mean(f)
quantile.surv <- Quantile(f)
latex(expected.surv, file='', type='Sinput')
latex(quantile.surv, file='', type='Sinput')
median.surv   <- function(x) quantile.surv(lp=x)

## ----nomogram, h=6, w=6, ps=10, cap='Nomogram for predicting median and mean survival time, based on approximation of full model',scap='Nomogram for simplified log-normal model'----
# Improve variable labels for the nomogram
f.approx <- Newlabels(f.approx, c('Disease Group','Mean Arterial BP',
          'Creatinine','Age','Heart Rate','SUPPORT Coma Score',
          'PaO2/(.01*FiO2)','ADL','Resp. Rate'))
nom <-
  nomogram(f.approx,
           pafi.i=c(0, 50, 100, 200, 300, 500, 600, 700, 800, 900),
           fun=list('Median Survival Time'=median.surv,
                   'Mean Survival Time'  =expected.surv),
           fun.at=c(.1,.25,.5,1,2,5,10,20,40))
plot(nom, cex.var=1, cex.axis=.75, lmgp=.25)
# Figure (*\ref{fig:support-nomogram}*)


require(rms)
require("MLmetrics")

#carregando dados
d <- read.csv("~/sid/usp/algo_am/porto/train.csv", header=T,dec=".", sep=",")
d_test <- read.csv("~/sid/usp/algo_am/porto/test.csv", header=T,dec=".", sep=",")
colnames(d)
summary(d[,3:ncol(d)])

#balanceamento manual
d_1 <- d[which(d$target==1),]
d_0a <- d[which(d$target==0),]
d_0 <- d_0a[1:nrow(d_1),]
dd <- rbind(d_1, d_0)
table(dd$target)

# modelo
#ps_ind_09_bin, ps_ind_14 <-- colunas problemáticas, investigar.
y <- target~ps_ind_01+ps_ind_02_cat+ps_ind_03+ps_ind_04_cat+ps_ind_05_cat+ps_ind_06_bin+ps_ind_07_bin+ps_ind_08_bin+ps_ind_10_bin+ps_ind_11_bin+ps_ind_12_bin+ps_ind_13_bin+ps_ind_15+ps_ind_16_bin+ps_ind_17_bin+ps_ind_18_bin+ps_reg_01+ps_reg_02+ps_reg_03+ps_car_01_cat+ps_car_02_cat+ps_car_03_cat+ps_car_04_cat+ps_car_05_cat+ps_car_06_cat+ps_car_07_cat+ps_car_08_cat+ps_car_09_cat+ps_car_10_cat+ps_car_11_cat+ps_car_11+ps_car_12+ps_car_13+ps_car_14+ps_car_15+ps_calc_01+ps_calc_02+ps_calc_03+ps_calc_04+ps_calc_05+ps_calc_06+ps_calc_07+ps_calc_08+ps_calc_09+ps_calc_10+ps_calc_11+ps_calc_12+ps_calc_13+ps_calc_14+ps_calc_15_bin+ps_calc_16_bin+ps_calc_17_bin+ps_calc_18_bin+ps_calc_19_bin+ps_calc_20_bin
m <- lrm(y, data=dd)
m

# avaliação nos dados de treinamento
p <- predict(m, data=dd, type="fitted")
y_pred <- round(p)
attach(dd)
table(target, y_pred)

Accuracy(y_pred, target)

plot(p[1:100], pch=18, col="red", xlim=c(1,100), ylim=c(0,1), ylab="probs",xlab="amostra")
abline(h=0.5, col="green", lty=2)

# avaliação nos dados de teste
p <- predict(m, data=d_test, type="fitted")
y_pred <- round(p)
table(y_pred)


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

wczytaj_energy_efficiency <- function(){

  energy <- read_excel("ENB2012_data.xlsx")

  names(energy)[1] <- "RelativeCompactness"
  names(energy)[2] <- "SurfaceArea"
  names(energy)[3] <- "WallArea"
  names(energy)[4] <- "RoofArea"
  names(energy)[5] <- "OverallHeight"
  names(energy)[6] <- "Orientation"
  names(energy)[7] <- "GlazingArea"
  names(energy)[8] <- "GlazingAreaDistribution"
  names(energy)[9] <- "HeatingLoad"
  names(energy)[10] <- "CoolingLoad"

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

  idx = which(colnames(energy) == "CoolingLoad")
  energy = energy[,-idx] #usuwanie zmiennej CoolingLoad ponieważ jest to inna zmienna "przewidywana" w danych co zaburzy nasze przewidywania HeatingLoad
  set.seed(123)

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

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

  #wybieranie kolumn "ważnych"
  tmp <- lm(HeatingLoad~1 , data = energy)
  forward <- step(tmp, direction = "forward", scope = list(upper=.~.+RelativeCompactness+SurfaceArea+WallArea+RoofArea+OverallHeight+Orientation+GlazingArea+GlazingAreaDistribution), trace=0)
  summary(forward)$r.squared#0.9161955

  tmp <- lm(HeatingLoad~RelativeCompactness+SurfaceArea+WallArea+RoofArea+OverallHeight+Orientation+GlazingArea+GlazingAreaDistribution , data = energy)
  backward <- step(tmp, direction = "backward", scope = list(upper=.~.+RelativeCompactness+SurfaceArea+WallArea+RoofArea+OverallHeight+Orientation+GlazingArea+GlazingAreaDistribution), trace=0)
  summary(backward)$r.squared#0.9161955

  tmp <- lm(HeatingLoad~. , data = energy)
  both <- step(tmp, direction = "both", scope = list(upper=.~.+RelativeCompactness+SurfaceArea+WallArea+RoofArea+OverallHeight+Orientation+GlazingArea+GlazingAreaDistribution), trace=0)
  summary(both)$r.squared #0.9161955

  nazwyKolumn <- variable.names(both) #Wszystkie wybrały ten sam model, wybieram "both"
  nazwyKolumn[1] <- "HeatingLoad" #poprawka nazwy

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

}

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