getMaxAlphaFilters <- function(g, max.vertices){
  el = get.data.frame(g)
  a = unique(data.frame(node=c(el$from,el$to), alpha=c(el$alpha,el$alpha)))
  a = a[order(a$alpha),]
  a = a[!duplicated(a$node),]
  if(nrow(a) <= max.vertices) {
    max.alpha = 1
    delete.vertices = c()
  } else {
    max.alpha = a$alpha[max.vertices]
    if(max.alpha == a$alpha[max.vertices+1]) max.alpha = max.alpha - 0.000000001
    delete.vertices = na.omit(a$node[(max.vertices+1):nrow(a)])
    delete.edges = which(el$from %in% delete.vertices | el$to %in% delete.vertices)
  }
  list(max.alpha=max.alpha, delete.edges=delete.edges)
}

filterVerticesByAlpha <- function(g, max.vertices, use.original.alpha){
  filters = getMaxAlphaFilters(g, max.vertices)

  if(filters$max.alpha < max(E(g)$alpha)) {
    message(paste('Used cutoff alpha', filters$max.alpha, 'to keep number of vertices under', max.vertices))
    if(use.original.alpha){
      message(paste('(For the edges the threshold assigned in the alpha parameter is still used)'))

      g = delete.edges(g, filters$delete.edges)
    } else {
      g = delete.edges(g, which(E(g)$alpha >= filters$max.alpha))
    }
  }
  g
}

#' Extract the backbone of a network.
#'
#' Based on the following paper: Serrano, M. Á., Boguñá, M., & Vespignani, A. (2009). Extracting the multiscale backbone of complex weighted networks. Proceedings of the National Academy of Sciences, 106(16), 6483-6488.
#'
#' @param g A graph in the `Igraph` format.
#' @param alpha The threshold for the alpha. Can be interpreted similar to a p value (see paper for clarrification).
#' @param direction direction = 'none' can be used for both directed and undirected networks, and is (supposed to be) the disparity filter proposed in Serrano et al. (2009) is used. By setting to 'in' or 'out', the alpha is only calculated for out or in edges. This is an experimental use of the backbone extraction (so beware!) but it seems a logical application.
#' @param delete.isolates If TRUE, vertices with degree 0 (i.e. no edges) are deleted.
#' @param max.vertices Optional. Set a maximum number of vertices for the network to be produced. The alpha is then automatically lowered to the point that only the given number of vertices remains connected (degree > 0). This can be usefull if the purpose is to make an interpretation friendly network. See e.g., http://jcom.sissa.it/archive/14/01/JCOM_1401_2015_A01
#' @param use.original.alpha if max.vertices is not NULL, this determines whether the lower alpha for selecting the top vertices is also used as a threshold for the edges, or whether the original value given in the alpha parameter is used.
#' @return A graph in the Igraph format
#' @export
getBackboneNetwork <- function(g, alpha=0.05, direction='none', delete.isolates=T, max.vertices=NULL, use.original.alpha=T, k.is.Nvertices=F){
  if (igraph::has.multiple(g)) stop('The semnet implementation of backbone extraction does not support parallel edges (i.e. having multiple edges between the same nodes with the same direction). If summing multiple edges is OK with you, you can use Igraphs simplify() function')

  if(direction == 'none') E(g)$alpha = backbone.alpha(g, k.is.Nvertices)
  if(direction == 'in') E(g)$alpha = backbone.indegree.alpha(g, k.is.Nvertices)
  if(direction == 'out') E(g)$alpha = backbone.outdegree.alpha(g, k.is.Nvertices)
  g = delete.edges(g, which(E(g)$alpha >= alpha))
  if(!is.null(max.vertices) & ecount(g) > 0) g = filterVerticesByAlpha(g, max.vertices, use.original.alpha)
  if(delete.isolates) g = delete.vertices(g, which(degree(g) == 0))
  if(ecount(g) == 0) {
    warning("No significant edges (backbone) remain!! Accept it (or lower the backbone_alpha)")
    return(g)
  }
  g
}

calcAlpha <- function(mat, weightsum, k){
  mat@x = mat@x / weightsum[mat@i+1]
  mat@x = (1 - mat@x)^(k[mat@i+1]-1)
  mat@x[is.na(mat@x)] = 1
  mat
}

#' Calculate the alpha values that can be used to extract the backbone of a network.
#'
#' Based on the following paper: Serrano, M. Á., Boguñá, M., & Vespignani, A. (2009). Extracting the multiscale backbone of complex weighted networks. Proceedings of the National Academy of Sciences, 106(16), 6483-6488.
#'
#' @param g A graph in the `Igraph` format.
#' @return A vector of alpha values, which matches the edges. Can thus easily be made an edge attribute: E(g)$alpha = backbone.alpha(g)
#' @export
backbone.alpha <- function(g, k.is.Nvertices=F){
  if (igraph::has.multiple(g)) stop('The semnet implementation of backbone extraction does not support parallel edges (i.e. having multiple edges between the same nodes with the same direction). If summing multiple edges is OK with you, you can use Igraphs simplify() function')

  mat = get.adjacency(g, attr='weight')
  edgelist_ids = get.edgelist(g, names=F)

  if(!is.directed(g)) {
    mat[lower.tri(mat)] = 0 # prevents counting edges double in symmetric matrix (undirected graph)
    weightsum_ij = weightsum_ji = Matrix::rowSums(mat) + Matrix::colSums(mat)
    k_ij = k_ji = if(k.is.Nvertices) nrow(mat) else Matrix::rowSums(mat>0) + Matrix::colSums(mat>0)
  } else {
    weightsum_ij = Matrix::rowSums(mat)
    weightsum_ji = Matrix::colSums(mat)
    k_ij = if(k.is.Nvertices) nrow(mat) else Matrix::rowSums(mat>0)
    k_ji = if(k.is.Nvertices) ncol(mat) else Matrix::colSums(mat>0)
  }
  alpha_ij = calcAlpha(mat, weightsum_ij, k_ij)[edgelist_ids] # alpha from the perspective of the 'from' node.
  alpha_ji = Matrix::t(calcAlpha(Matrix::t(mat), weightsum_ji, k_ji))[edgelist_ids] # alpha from the perspective of the 'to' node.
  ifelse(alpha_ij < alpha_ji, alpha_ij, alpha_ji) # select lowest alpha, because an edge can be 'significant' from the perspective of both the 'from' and 'to' node.

}

#' Calculate the alpha values that can be used to extract the backbone of a network, for only the out.degree
#'
#' Based on the following paper: Serrano, M. Á., Boguñá, M., & Vespignani, A. (2009). Extracting the multiscale backbone of complex weighted networks. Proceedings of the National Academy of Sciences, 106(16), 6483-6488.
#'
#' @param g A graph in the `Igraph` format.
#' @return A vector of alpha values, which matches the edges. Can thus easily be made an edge attribute: E(g)$alpha = backbone.alpha(g)
#' @export
backbone.outdegree.alpha <- function(g, k.is.Nvertices=F){
  if (igraph::has.multiple(g)) stop('The semnet implementation of backbone extraction does not support
                                     parallel edges (i.e. having multiple edges between the same nodes
                                     with the same direction). If summing multiple edges into single
                                     weighted edges is OK with you, you can use Igraphs simplify() function')

  mat = get.adjacency(g, attr='weight')
  weightsum = Matrix::rowSums(mat)
  k = if(k.is.Nvertices) nrow(mat) else Matrix::rowSums(mat > 0)
  edgelist_ids = get.edgelist(g, names=F)
  calcAlpha(mat, weightsum, k)[edgelist_ids]
}

#' Calculate the alpha values that can be used to extract the backbone of a network, for only the in.degree
#'
#' Based on the following paper: Serrano, M. Á., Boguñá, M., & Vespignani, A. (2009). Extracting the multiscale backbone of complex weighted networks. Proceedings of the National Academy of Sciences, 106(16), 6483-6488.
#'
#' @param g A graph in the `Igraph` format.
#' @return A vector of alpha values, which matches the edges. Can thus easily be made an edge attribute: E(g)$alpha = backbone.alpha(g)
#' @export
backbone.indegree.alpha <- function(g, k.is.Nvertices=F){
  if (igraph::has.multiple(g)) stop('The semnet implementation of backbone extraction does not support parallel edges (i.e. having multiple edges between the same nodes with the same direction). If summing multiple edges is OK with you, you can use Igraphs simplify() function')

  mat = get.adjacency(g, attr='weight')
  weightsum = Matrix::colSums(mat)
  k = if(k.is.Nvertices) nrow(mat) else Matrix::colSums(mat > 0)
  edgelist_ids = get.edgelist(g, names=F)
  Matrix::t(calcAlpha(Matrix::t(mat), weightsum, k))[edgelist_ids]
}


################################################################################
# Part of the R/EpiILM package
#
# AUTHORS:
#         Waleed Almutiry <wkmtierie@qu.edu.sa>,
#         Vineetha Warriyar. K. V. <vineethawarriyar.kod@ucalgary.ca>, and
#         Rob Deardon <robert.deardon@ucalgary.ca>
#
# Algorithm based on:
#                Deardon R, Brooks, S. P., Grenfell, B. T., Keeling, M. J., Tildesley,
#                M. J., Savill, N. J., Shaw, D. J.,  Woolhouse, M. E. (2010).
#                Inference for individual level models of infectious diseases in large
#                populations. Statistica Sinica, 20, 239-261.
#
# Free software under the terms of the GNU General Public License, version 2,
# a copy of which is available at http://www.r-project.org/Licenses/.
################################################################################

pred.epi <- function (object, xx, criterion , n.samples, burnin = NULL, tmin = NULL, Sformula = NULL, Tformula = NULL, showProgressBar = interactive()) {

	if (!is(object, "epidata")) {
		stop("The object of the epidemic data must be in a class of \"epidata\"", call. = FALSE)
	}

	if (!is(xx, "epimcmc")) {
		stop("The object of the MCMC samples must be in a class of \"epimcmc\"", call. = FALSE)
	}

	n <- length(object$inftime)

	if (is.null(burnin)) {
		burnin <- 1
	}

	if (is.null(tmin)){
		tmin = 1
	}

	t_end <- max(object$inftime)

	ns <- xx$n.sus.par
	nt <- xx$n.trans.par
	ni <- xx$n.ker.par

    if (object$type == "SIR") {
        infperiod = object$remtime - object$inftime
    } else {
        infperiod = NULL
    }

	mcmcout_posterior <- matrix(xx$Fullsample[sample(seq(burnin,length(xx$Fullsample[,1])), n.samples, replace = FALSE), ],
                            nrow = n.samples,
                            ncol = ncol(xx$Fullsample))

	newinftime <- replace(object$inftime, object$inftime > tmin, 0)
	out1 <- vector(mode = "list", length = n.samples)

	if (is.null(object$contact)) {

		x <- object$XYcoordinates[,1]
		y <- object$XYcoordinates[,2]

		if (all((nt == 0) & (ns + ni) == ncol(xx$Fullsample)) == TRUE) {

			cat("generate", n.samples, "epidemics \n")
			if (showProgressBar) {
	    pb <- txtProgressBar(min = 0, max = n.samples, style = 3)
			}
			update.step <- max(5, floor(n.samples/100))

			for (i in 1:n.samples) {
				if (showProgressBar && i %% update.step == 0) {
		      setTxtProgressBar(pb, i)
		    }

				out1[[i]] <- epidata(type = object$type, n = n, tmax = t_end, Sformula = Sformula, tmin = tmin,
				sus.par = c(mcmcout_posterior[i, 1: ns]),
				beta = c(mcmcout_posterior[i, (ns + 1): (ns + ni)]),
				x = x, y = y, inftime = newinftime, infperiod = infperiod)

			}
			if (showProgressBar) {
				close(pb)
			}
		} else if (all((nt > 0) & (ns + nt + ni) == ncol(xx$Fullsample)) == TRUE) {

			cat("  generate", n.samples, "epidemics \n")
			if (showProgressBar) {
			pb <- txtProgressBar(min = 0, max = n.samples, style = 3)
			}
			update.step <- max(5, floor(n.samples/100))

			for (i in 1:n.samples) {

				if (showProgressBar && i %% update.step == 0) {
					setTxtProgressBar(pb, i)
				}

				out1[[i]] <- epidata(type = object$type, n = n, tmax = t_end, Sformula = Sformula, Tformula = Tformula, tmin = tmin,
				sus.par = c(mcmcout_posterior[i, 1:ns]), trans.par = c(mcmcout_posterior[i, (ns+1): (ns+nt)]),
				beta = c(mcmcout_posterior[i, (ns+nt+1): (ns+nt+ni)]),
				x = x, y = y, inftime = newinftime, infperiod = infperiod)

			}
			if (showProgressBar) {
				close(pb)
			}

		} else if (all((nt == 0) & (ns + ni) < ncol(xx$Fullsample)) == TRUE) {

			cat("  generate", n.samples, "epidemics \n")
			if (showProgressBar) {
			pb <- txtProgressBar(min = 0, max = n.samples, style = 3)
			}
			update.step <- max(5, floor(n.samples/100))

			for (i in 1:n.samples) {

				if (showProgressBar && i %% update.step == 0) {
					setTxtProgressBar(pb, i)
				}

				out1[[i]] <- epidata(type = object$type, n = n, tmax = t_end, Sformula = Sformula, tmin = tmin,
				sus.par = c(mcmcout_posterior[i, 1: ns]), trans.par = 1,
				beta = c(mcmcout_posterior[i, (ns + 1): (ns + ni)]),
				spark = mcmcout_posterior[i, (ns + ni + 1)],
				x = x, y = y, inftime = newinftime, infperiod = infperiod)
			}
			if (showProgressBar) {
				close(pb)
			}

		} else if (all((nt > 0) & (ns + nt + ni) < ncol(xx$Fullsample)) == TRUE) {

			cat("  generate", n.samples, "epidemics \n")
			if (showProgressBar) {
			pb <- txtProgressBar(min = 0, max = n.samples, style = 3)
			}
			update.step <- max(5, floor(n.samples/100))

			for (i in 1:n.samples) {

				if (showProgressBar && i %% update.step == 0) {
					setTxtProgressBar(pb, i)
				}

				out1[[i]] <- epidata(type = object$type, n = n, tmax = t_end, Sformula = Sformula, Tformula = Tformula, tmin = tmin,
				sus.par = c(mcmcout_posterior[i, 1:ns]), trans.par = c(mcmcout_posterior[i, (ns+1): (ns+nt)]),
				beta = c(mcmcout_posterior[i, (ns+nt+1): (ns+nt+ni)]),
				spark = c(mcmcout_posterior[i, (ns+nt+ni+1)]),
				x = x, y = y, inftime = newinftime, infperiod = infperiod)

			}
			if (showProgressBar) {
				close(pb)
			}
		}

	} else {

		contact <- object$contact

		if (all((nt == 0) & (ns + ni) == ncol(xx$Fullsample)) == TRUE) {

			cat("  generate", n.samples, "epidemics \n")
			if (showProgressBar) {
			pb <- txtProgressBar(min = 0, max = n.samples, style = 3)
			}
			update.step <- max(5, floor(n.samples/100))

			for (i in 1:n.samples) {

				if (showProgressBar && i %% update.step == 0) {
					setTxtProgressBar(pb, i)
				}

        if (ni != 0) {
  				out1[[i]] <- epidata(type = object$type, n = n, tmax = t_end, Sformula = Sformula, tmin = tmin,
    				sus.par = c(mcmcout_posterior[i, 1: ns]),
    				beta = c(mcmcout_posterior[i, (ns + 1): (ns + ni)]),
    				contact = contact, inftime = newinftime, infperiod = infperiod)
        } else if (ni == 0) {
  				out1[[i]] <- epidata(type = object$type, n = n, tmax = t_end, Sformula = Sformula, tmin = tmin,
    				sus.par = c(mcmcout_posterior[i, 1: ns]),
    				contact = contact, inftime = newinftime, infperiod = infperiod)
        }
			}
			if (showProgressBar) {
				close(pb)
			}

		} else if (all((nt > 0) & (ns + nt + ni) == ncol(xx$Fullsample)) == TRUE) {

			cat("  generate", n.samples, "epidemics \n")
			if (showProgressBar) {
			pb <- txtProgressBar(min = 0, max = n.samples, style = 3)
			}
			update.step <- max(5, floor(n.samples/100))

			for (i in 1:n.samples) {

				if (showProgressBar && i %% update.step == 0) {
					setTxtProgressBar(pb, i)
				}

        if (ni != 0) {
  				out1[[i]] <- epidata(type = object$type, n = n, tmax = t_end, Sformula = Sformula, Tformula = Tformula, tmin = tmin,
    				sus.par = c(mcmcout_posterior[i, 1:ns]), trans.par = c(mcmcout_posterior[i, (ns+1): (ns+nt)]),
    				beta = c(mcmcout_posterior[i, (ns+nt+1): (ns+nt+ni)]),
    				contact = contact, inftime = newinftime, infperiod = infperiod)
        } else if (ni == 0) {
          out1[[i]] <- epidata(type = object$type, n = n, tmax = t_end, Sformula = Sformula, Tformula = Tformula, tmin = tmin,
            sus.par = c(mcmcout_posterior[i, 1:ns]), trans.par = c(mcmcout_posterior[i, (ns+1): (ns+nt)]),
            contact = contact, inftime = newinftime, infperiod = infperiod)
        }
			}
			if (showProgressBar) {
				close(pb)
			}

		} else if (all((nt == 0) & (ns + ni) < ncol(xx$Fullsample)) == TRUE) {

			cat("  generate", n.samples, "epidemics \n")
			if (showProgressBar) {
			pb <- txtProgressBar(min = 0, max = n.samples, style = 3)
			}
			update.step <- max(5, floor(n.samples/100))

			for (i in 1:n.samples) {

				if (showProgressBar && i %% update.step == 0) {
					setTxtProgressBar(pb, i)
				}

        if (ni != 0) {
  				out1[[i]] <- epidata(type = object$type, n = n, tmax = t_end, Sformula = Sformula, tmin = tmin,
    				sus.par = c(mcmcout_posterior[i, 1: ns]),
    				beta = c(mcmcout_posterior[i, (ns + 1): (ns + ni)]),
    				spark = mcmcout_posterior[i, (ns + ni + 1)],
    				contact = contact, inftime = newinftime, infperiod = infperiod)
        } else if (ni == 0) {
          out1[[i]] <- epidata(type = object$type, n = n, tmax = t_end, Sformula = Sformula, tmin = tmin,
            sus.par = c(mcmcout_posterior[i, 1: ns]),
            spark = mcmcout_posterior[i, (ns + ni + 1)],
            contact = contact, inftime = newinftime, infperiod = infperiod)
        }
			}

			if (showProgressBar) {
				close(pb)
			}

		} else if (all((nt > 0) & (ns + nt + ni) < ncol(xx$Fullsample)) == TRUE) {

			cat("  generate", n.samples, "epidemics \n")
			if (showProgressBar) {
			pb <- txtProgressBar(min = 0, max = n.samples, style = 3)
			}
			update.step <- max(5, floor(n.samples/100))

			for (i in 1:n.samples) {

				if (showProgressBar && i %% update.step == 0) {
					setTxtProgressBar(pb, i)
				}

        if (ni != 0) {
          out1[[i]] <- epidata(type = object$type, n = n, tmax = t_end, Sformula = Sformula, Tformula = Tformula, tmin = tmin,
            sus.par = c(mcmcout_posterior[i, 1:ns]), trans.par = c(mcmcout_posterior[i, (ns+1): (ns+nt)]),
            beta = c(mcmcout_posterior[i, (ns+nt+1): (ns+nt+ni)]),
            spark = c(mcmcout_posterior[i, (ns+nt+ni+1)]),
            contact = contact, inftime = newinftime, infperiod = infperiod)
        } else if (ni == 0) {
          out1[[i]] <- epidata(type = object$type, n = n, tmax = t_end, Sformula = Sformula, Tformula = Tformula, tmin = tmin,
            sus.par = c(mcmcout_posterior[i, 1:ns]), trans.par = c(mcmcout_posterior[i, (ns+1): (ns+nt)]),
            spark = c(mcmcout_posterior[i, (ns+nt+ni+1)]),
            contact = contact, inftime = newinftime, infperiod = infperiod)
        }
			}
			if (showProgressBar) {
				close(pb)
			}
		}

	}

	if (criterion == "newly infectious") {

		crit <- matrix(0, ncol = t_end, nrow = n.samples)

		for (j in 1:n.samples) {
			newinf <- rep(0)
			for (i in 1: t_end) {
				newinf[i] <- sum(out1[[j]]$inftime == i)
			}
			crit[j,] <- newinf
		}

		crit_true <- rep(0)
		for (i in 1: t_end) {
			crit_true[i] <- length(object$inftime[object$inftime == i])
		}

		result <- list(type = object$type, criterion = criterion, crit.sim = crit, crit.obs = crit_true, tmin = tmin, tmax = t_end, n.samples = n.samples)

	} else if (criterion == "epidemic length") {

		if (object$type == "SI") {

			crit <- NULL

			for (j in 1:n.samples) {
				crit[j] <- max(out1[[j]]$inftime) - min(out1[[j]]$inftime)
			}

			crit_true <- max(object$inftime) - min(object$inftime)

		} else if (object$type == "SIR") {

			crit <- NULL

			for (j in 1:n.samples) {
				crit[j] <- max(out1[[j]]$remtime) - min(out1[[j]]$inftime)
			}

			crit_true <- max(object$remtime) - min(object$inftime)

		}
			result <- list(type = object$type, criterion = criterion, crit.sim = crit, crit.obs = crit_true, tmin = tmin, tmax = t_end, n.samples = n.samples)

			} else if (criterion == "peak time") {

		    if (object$type == "SI") {

		      crit <- NULL

		      for (j in 1:n.samples) {

		        oot <- out1[[j]]$inftime[which(out1[[j]]$inftime!=0)]

		        dff <- as.data.frame(table(oot))

		        res <- dff[which(dff[, 2] == max(dff[, 2])), 1]

		        if (length(res) > 1) {

		          crit[j] <- max(as.numeric(as.character(res)))

		        } else {

		          crit[j] <- as.numeric(as.character(res))

		        }

		      }

		      oot <- object$inftime[which(object$inftime!=0)]

		      dff <- as.data.frame(table(oot))

		      crit_true <- max(as.numeric(as.character(dff[which(dff[, 2] == max(dff[, 2])), 1])))

		      result <- list(type = object$type, criterion = criterion, crit.sim = crit, crit.obs = crit_true, tmin = tmin, tmax = t_end, n.samples = n.samples)

		    } else if (object$type == "SIR") {

		      crit_inf <- NULL

		      crit_rem <- NULL

		      for (j in 1:n.samples) {

		        oot <- out1[[j]]$inftime[which(out1[[j]]$inftime!=0)]

		        oot1 <- out1[[j]]$remtime[which(out1[[j]]$remtime!=0)]

		        dff <- as.data.frame(table(oot))

		        dff1 <- as.data.frame(table(oot1))

		        res <- dff[which(dff[, 2] == max(dff[, 2])), 1]

		        res1<- dff1[which(dff1[, 2] == max(dff1[, 2])), 1]

		        if (length(res) > 1) {

		          crit_inf[j] <- max(as.numeric(as.character(res)))

		        } else {

		          crit_inf[j] <- as.numeric(as.character(res))

		        }

		        if (length(res1) > 1) {

		          crit_rem[j] <- max(as.numeric(as.character(res1)))

		        } else {

		          crit_rem[j] <- as.numeric(as.character(res1))

		        }

		      }

		      oot <- object$inftime[which(object$inftime!=0)]

		      oot1 <- object$remtime[which(object$remtime!=0)]

		      dff <- as.data.frame(table(oot))

		      dff1 <- as.data.frame(table(oot1))

		      crit_true_inf <- max(as.numeric(as.character(dff[which(dff[, 2] == max(dff[, 2])), 1])))

		      crit_true_rem <- max(as.numeric(as.character(dff1[which(dff1[, 2] == max(dff1[, 2])), 1])))

		      result <- list(type = object$type, criterion = criterion, crit.sim = list(crit_inf, crit_rem),
		                     crit.obs = list(crit_true_inf, crit_true_rem), tmin = tmin, tmax = t_end, n.samples = n.samples)

		    }

		  }

		  class(result) <- "pred.epi"

		  result

}

plot.pred.epi <- function (x, ...) {

	if (!is(x, "pred.epi")) {
		stop("The object must be in a class of \"pred.epi\"", call. = FALSE)
	}

	if (x$criterion == "newly infectious") {

		lowerq <- NULL
		upperq <- NULL

		for (i in 1: x$tmax) {
			lowerq[i] <- quantile(x$crit.sim[,i], 0.025)
			upperq[i] <- quantile(x$crit.sim[,i], 0.975)
		}

		time <- rep(1: x$tmax)
		mx <- max(upperq)
		mn <- min(lowerq)

		plot (time, x$crit.obs, xlim = c(min(time), max(time)), ylim = c(mn, mx),
			ylab = "Newly infections", xlab =" Time", xaxt = "n", col = "black", type = "o", pch = 20)

		axis(1, at = 1:max(time))

		for (i in 1: x$n.samples) {
            lines(time[x$tmin:x$tmax], x$crit.sim[i,x$tmin:x$tmax], col = "grey", lwd = 0.2)
		}

    lines(time[x$tmin:x$tmax], apply(x$crit.sim[,x$tmin:x$tmax], 2, mean), lty = 1, ...)
    lines(time, x$crit.obs, col = "black", type = "o", pch = 20, lwd = 2)

		axis(1, at = 1:max(time))
		lines(time[x$tmin:x$tmax], lowerq[x$tmin:x$tmax], lty = 2, ...)
		lines(time[x$tmin:x$tmax], upperq[x$tmin:x$tmax], lty = 2, ...)

	} else if (x$criterion == "epidemic length") {

		hist(x$crit.sim, main = "", xlab = "The length of epidemic", ylab = "Time", ...)
		abline(v = quantile(x$crit.sim, c(0.025, 0.975)), col = "red", lty = 2)
		abline(v = mean(x$crit.sim), col = "red")
		abline(v = x$crit.obs, col = "blue")

	} else if (x$criterion == "peak time") {

		if(x$type == "SI") {

			hist(x$crit.sim, main = "", xlab = "The time of the peak of infection times", ylab = "Time", ...)
			abline(v = quantile(x$crit.sim, c(0.025, 0.975)), col = "red", lty = 2)
			abline(v = mean(x$crit.sim), col = "red")
			abline(v = x$crit.obs, col = "blue")

		} else if (x$type == "SIR") {

      par(mfrow = c(1, 2))

			hist(x$crit.sim[[1]], main = "", xlab = "The time of the peak of infection times", ylab = "Time", ...)
			abline(v = quantile(x$crit.sim[[1]], c(0.025, 0.975)), col = "red", lty = 2)
			abline(v = mean(x$crit.sim[[1]]), col = "red")
			abline(v = x$crit.obs[[1]], col = "blue")

			hist(x$crit.sim[[2]], main = "", xlab = "The time of the peak of removal times", ylab = "Time", ...)
			abline(v = quantile(x$crit.sim[[2]], c(0.025, 0.975)), col = "red", lty = 2)
			abline(v = mean(x$crit.sim[[2]]), col = "red")
			abline(v = x$crit.obs[[2]], col = "blue")

		}
	}
}


#'@title calcPropPwr
#'
#'@description Calculates ship power (kW) using the propeller law.
#'
#' @param totalInstalledPwr Total installed main engine power (vector of
#' numericals, kW) (maximum
#' continuous rated power)
#' @param shipSpeed Ship actual speed (vector of numericals, m/s) (see
#' \code{\link{calcSpeedUnitConversion}})
#' @param refSpeed Reference speed of the ship (service speed or maximum speed)
#' (vector of numericals, m/s)
#' @param serviceMargin A service margin to account for weather and sea effects:
#' \itemize{\item At-sea operations = 15 (Default) \item Coastal operations = 10}
#' Can supply either a vector of numericals, a single number, or rely on the default
#' @param n Exponential relationship applied to the ship speed ratio (dimensionless).
#' Default = 3. This argument is not vectorized, so supply a single number or rely
#' on the default
#' @param refSpeedType Indicates if the reference speed is service speed or
#' maximum speed: \itemize{
#' \item "serviceSpeed (Default)"
#' \item "maxSpeed"}
#' Can supply either a vector of strings, a single value, or rely on the default.
#'
#'@return power (vector of numericals, kW)
#'
#'@details
#' Ship speed and actual draft are typically obtained from sources such as AIS
#' messages or ship records.
#'
#' serviceMargin = 10 or 15, based on IMO (Prpic Orsic and Faltinsen, 2012).
#' 15 indicates 15\% increased resistance in at-sea water conditions, and 10
#' indicates 10\% increased resistance in coastal water conditions.
#'
#' Note that service margin is treated as an added resistance here
#' (instead of as a reduced efficiency) to maintain consistency with the other
#' power models used in this library. (See MAN, 2011).
#'
#'@references
#'\href{https://nepis.epa.gov/Exe/ZyPURL.cgi?Dockey=P1005ZGH.TXT}{EPA. 2009.
#'"Regulatory impact analysis: Control of emissions air pollution from category
#'3 marine diesel engines." Ann Arbor, MI: Office of Transportation and Air
#'Quality. US Environmental Protection Agency.}
#'
#'\href{https://www.man-es.com/marine/products/propeller-aft-ship}{MAN Energy
#' Solutions. 2011. "Basic Principles of Propulsion."}
#'
#'@seealso \itemize{
#'\item \code{\link{calcSpeedUnitConversion}}
#'\item \code{\link{calcAdmPwr}}
#'\item \code{vignette("OverviewOfPowerModels", package="ShipPowerModel")}
#'\item \code{vignette("Propeller.Law.Example", package="ShipPowerModel")}
#'}
#'
#'@examples
#'calcPropPwr(totalInstalledPwr = 9363,
#'            shipSpeed = seq(10,14,1),
#'            refSpeed = 15,
#'            serviceMargin = 15,
#'            n = 3)
#'
#'@export

calcPropPwr <- function(totalInstalledPwr, shipSpeed, refSpeed, serviceMargin=15, n=3,refSpeedType = "serviceSpeed"){

  #The propeller law method requires the the reference speed to be maximum speed, to be consistent with the other terms
  #Convert service speed to maximum speed by assuming service speed is 94% of maximum speed
  refSpeed<-ifelse(tolower(refSpeedType) == "servicespeed",
                   refSpeed/0.94,
                   refSpeed
                   )#end ifelse

  power <- ifelse(shipSpeed==0,
                  0,
                  (totalInstalledPwr*
                    pmin(1,#set maximum power to 100%
                         pmax(.02,#limit minimum power to 2%
                              (shipSpeed/refSpeed)^(n)*
                              ((100+serviceMargin)/100)
                             )
                        )
                  )
                 )#end ifelse
  return(power)
}


#### 반복측정 분산분석(Repeated Measures ANOVA) #####

# 01.데이터 불러오기
rma.df <- read.csv("Ch0902.RMA.csv",
                    header=TRUE,
                    na.strings = ".")
str(rma.df)
View(rma.df)
rma.df$time <- factor(rma.df$time,
                        levels=c(1:3),
                        labels=c("사전","3개월","6개월")                       )

# 02.기본통계치 확인
library(psych)
describeBy(rma.df$score, rma.df$time, mat=T)

# 03.그래프 그리기(박스그래프,히스토그램)
boxplot(score ~ time,
        data=rma.df,
        ylab="score",
        xlab="time")

# 04.통계분석
# 다변량 분석을 이용한 구형성(sphericity)검정: Mauchly’s test. 분산의 동질성 검정 방법 레빈 기법 활용한 것과 같은 논리
  # 매트릭스를 만들어서 해야 한다. 어려우니 잘 따라서 하자. (두번하면 대응표본이지만, 세번하면 분산분석임)
  # 현재 데이터 구조를 바꾸어야 하기 때문에

library(car)
rma.matrix <- cbind(rma.df$score[rma.df$time=="사전"], # 따로따로 뽑아서 옆으로 합쳐라
                    rma.df$score[rma.df$time=="3개월"],
                    rma.df$score[rma.df$time=="6개월"])
head(rma.matrix)

rma.model.lm <- lm(rma.matrix ~ 1) # ~1 : 데이터를 하나로 묶기
time.f <- factor(c("사전","3개월","6개월")) # 시간을 적자 (실제 사용할 때에는  여기만 변경해 주면 된다)
options(contrasts=c("contr.sum", "contr.poly"))
rma.result.mt <- Anova(rma.model.lm, #Anova 대문자
                       idata=data.frame(time.f),
                       idesign=~time.f,
                       type="III")

summary(rma.result.mt, multivariate=F)

# 일변량 ANOVA 검정
rma.result <- aov(score ~ time+Error(id/time),
                  data=rma.df)
summary(rma.result)

options("scipen" = 20)

# 다중비교 (Multicamparison test) - t-value 포함
# install.packages("multcomp")
library(multcomp)
result.lm <- lm(score ~ time, data=rma.df)
tukey.result <- glht(result.lm, linfct=mcp(time='Tukey'))
summary(tukey.result)
plot(tukey.result)

# 부록: 사후검정(기본함수사용): Tukey HSD
tukey.result <- aov(rma.df$score ~ rma.df$time, data=rma.df)
TukeyHSD(tukey.result)
plot(TukeyHSD(tukey.result))

ch09 - 분산분석 1/02.반복측정 분산분석(Repeated Measures ANOVA).r


#' Diagonal Linear Discriminant Analysis (DLDA)
#'
#' Given a set of training data, this function builds the Diagonal Linear
#' Discriminant Analysis (DLDA) classifier, which is often attributed to Dudoit
#' et al. (2002). The DLDA classifier belongs to the family of Naive Bayes
#' classifiers, where the distributions of each class are assumed to be
#' multivariate normal and to share a common covariance matrix.
#'
#' The DLDA classifier is a modification to the well-known LDA classifier, where
#' the off-diagonal elements of the pooled sample covariance matrix are assumed
#' to be zero -- the features are assumed to be uncorrelated. Under multivariate
#' normality, the assumption uncorrelated features is equivalent to the
#' assumption of independent features. The feature-independence assumption is a
#' notable attribute of the Naive Bayes classifier family. The benefit of these
#' classifiers is that they are fast and have much fewer parameters to estimate,
#' especially when the number of features is quite large.
#'
#' The matrix of training observations are given in `x`. The rows of `x`
#' contain the sample observations, and the columns contain the features for each
#' training observation.
#'
#' The vector of class labels given in `y` are coerced to a `factor`.
#' The length of `y` should match the number of rows in `x`.
#'
#' An error is thrown if a given class has less than 2 observations because the
#' variance for each feature within a class cannot be estimated with less than 2
#' observations.
#'
#' The vector, `prior`, contains the _a priori_ class membership for
#' each class. If `prior` is NULL (default), the class membership
#' probabilities are estimated as the sample proportion of observations belonging
#' to each class. Otherwise, `prior` should be a vector with the same length
#' as the number of classes in `y`. The `prior` probabilities should be
#' nonnegative and sum to one.
#'
#' @export
#'
#' @param x Matrix or data frame containing the training data. The rows are the
#' sample observations, and the columns are the features. Only complete data are
#' retained.
#' @param y Vector of class labels for each training observation. Only complete
#' data are retained.
#' @param prior Vector with prior probabilities for each class. If NULL
#' (default), then equal probabilities are used. See details.
#' @return  The model fitting function returns the fitted classifier. The
#' `predict()` method returns either a vector (`type = "class"`) or a data
#' frame (all other `type` values).
#' @references Dudoit, S., Fridlyand, J., & Speed, T. P. (2002). "Comparison of
#' Discrimination Methods for the Classification of Tumors Using Gene Expression
#' Data," Journal of the American Statistical Association, 97, 457, 77-87.
#' @examples
#' library(modeldata)
#' data(penguins)
#' pred_rows <- seq(1, 344, by = 20)
#' penguins <- penguins[, c("species", "body_mass_g", "flipper_length_mm")]
#' dlda_out <- lda_diag(species ~ ., data = penguins[-pred_rows, ])
#' predicted <- predict(dlda_out, penguins[pred_rows, -1], type = "class")
#'
#' dlda_out2 <- lda_diag(x = penguins[-pred_rows, -1], y = penguins$species[-pred_rows])
#' predicted2 <- predict(dlda_out2, penguins[pred_rows, -1], type = "class")
#' all.equal(predicted, predicted2)
lda_diag <- function(x, ...) {
  UseMethod("lda_diag")
}

#' @importFrom stats complete.cases
#' @rdname lda_diag
#' @export
lda_diag.default <- function(x, y, prior = NULL, ...) {
  x <- pred_to_matrix(x)
  y <- outcome_to_factor(y)
  complete <- complete.cases(x) & complete.cases(y)
  x <- x[complete,,drop = FALSE]
  y <- y[complete]

  obj <- diag_estimates(x = x, y = y, prior = prior, pool = TRUE)

  # Creates an object of type 'lda_diag'
  # Use columns that pass filters
  obj$col_names <- names(obj$est[[1]]$xbar)
  obj <- new_discrim_object(obj, "lda_diag")

  obj
}

#' @param formula A formula of the form `groups ~ x1 + x2 + ...` That is,
#' the response is the grouping factor and the right hand side specifies the
#' (non-factor) discriminators.
#' @param data data frame from which variables specified in `formula` are
#' preferentially to be taken.
#' @rdname lda_diag
#' @importFrom stats model.frame model.matrix model.response
#' @export
lda_diag.formula <- function(formula, data, prior = NULL, ...) {
  # The formula interface includes an intercept. If the user includes the
  # intercept in the model, it should be removed. Otherwise, errors and doom
  # happen.
  # To remove the intercept, we update the formula, like so:
  # (NOTE: The terms must be collected in case the dot (.) notation is used)
  formula <- no_intercept(formula, data)

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

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

#' Outputs the summary for a DLDA classifier object.
#'
#' Summarizes the trained DLDA classifier in a nice manner.
#'
#' @param x object to print
#' @param ... unused
#' @export
#' @keywords internal
print.lda_diag <- function(x, ...) {
  cat("Diagonal LDA\n\n")

  print_basics(x, ...)
  invisible(x)
}

#' DLDA prediction of the class membership of a matrix of new observations.
#'
#' The DLDA classifier is a modification to LDA, where the off-diagonal elements
#' of the pooled sample covariance matrix are set to zero.
#'
#' @rdname lda_diag
#' @export
#' @param object Fitted model object
#' @param newdata Matrix or data frame of observations to predict. Each row
#' corresponds to a new observation.
#' @param type Prediction type: either `"class"`, `"prob"`, or `"score"`.
#' @param ... additional arguments (not currently used).
predict.lda_diag <- function(object, newdata, type = c("class", "prob", "score"), ...) {
  type <- rlang::arg_match0(type, c("class", "prob", "score"), arg_nm = "type")
  newdata <- process_newdata(object, newdata)

  scores <- apply(newdata, 1, function(obs) {
    sapply(object$est, function(class_est) {
      with(class_est, sum((obs - xbar)^2 / object$var_pool) + log(prior))
    })
  })

  if (type == "prob") {
    # Posterior probabilities via Bayes Theorem
    means <- lapply(object$est, "[[", "xbar")
    covs <- replicate(n = object$num_groups, object$var_pool, simplify = FALSE)
    priors <- lapply(object$est, "[[", "prior")
    res <- posterior_probs(x = newdata, means = means, covs = covs, priors = priors)
    res <- as.data.frame(res)
  } else if (type == "class") {
    res <- score_to_class(scores, object)
  } else {
    res <- t(scores)
    res <- as.data.frame(res)
  }
  res
}


# Estimate Z from catch curves using 4 year moving window with cohort-specific coefficients
# based on Sinclair 2001 ICES J Mar Sci 58: 1-10

# matrix has year in rows and age in columns
calc_Sinclair_Z <- function(mat){
  res <- list()
  mat <- as.matrix(mat)
  if (all(is.na(mat))){
    res$error <- TRUE
    return(res)
  }
  year <- as.numeric(rownames(mat))
  age <- as.numeric(colnames(mat))
  ny <- length(year)
  est.Sinclair.Z <- matrix(NA, nrow=(ny-3), ncol=3)
  plot.year <- rep(NA, ny-3)
  for (i in 1:(ny-3)){
    submat <- mat[year %in% year[i:(i+3)],]
    data <- reshape2::melt(submat)
    colnames(data) <- c("Year","Age","Value")
    data$cohort <- data$Year - data$Age
    data$Value[data$Value == 0] <- NA
    data <- data[!is.na(data$Value) ,]
    data$lnVal <- log(data$Value)
    can.calc <- FALSE
    if (length(data[,1]) >= 2){
      if (max(table(data$cohort)) >= 3){
        can.calc <- TRUE
      }
    }
    if (can.calc == TRUE){
      my.lm <- lm(data$lnVal ~ as.factor(data$cohort) + data$Age)
      data$pred <- predict(my.lm)
      data$resid <- residuals(my.lm)
      res[[i]] <- data
      est.Sinclair.Z[i,1] <- -1 * my.lm$coefficients[names(my.lm$coefficients) == "data$Age"]
      est.Sinclair.Z[i,2:3] <- -1 * rev(confint(my.lm, "data$Age", level=0.90))
    }
    else{
      res[[i]] <- data
      est.Sinclair.Z[i,] <- rep(NA, 3)
    }
    plot.year[i] <- year[i] + 1.5
  }
  colnames(est.Sinclair.Z) <- c("Sinclair_Z","low90%","high90%")
  res$est.Sinclair.Z <- est.Sinclair.Z
  res$plot.year <- plot.year
  res$error <- FALSE
  return(res)
}

#-------------------------------------------------------------------------------------
# function to plot the results from calc_Sinclair_Z
# res is a list generated by the function calc_Sinclair_Z
plot_Sinclair_Z <- function(res,est.Z.name,regress.name,resid.name,my.title,save.plots,od,plotf){
  # first the plot of estimated Z with CI over time
  est.Z <- res$est.Sinclair.Z
  if (!all(is.na(est.Z))){
    par(mfcol=c(1,1), oma=rep(1,4), mar=rep(4,4))
    plot.year <- res$plot.year
    Hmisc::errbar(plot.year,est.Z[,1],est.Z[,3],est.Z[,2],ylim=c(0,max(est.Z, na.rm=T)),xlab="Year",ylab="Sinclair Z")
    if(!is.na(my.title)) title(main=my.title, outer=F)
    if(save.plots) savePlot(paste0(od,est.Z.name,".",plotf), type=plotf)
  }

  # plot the individual regressions
  ny <- length(res$plot.year)
  np.row <- 3             # number of plot rows
  np.col <- 3             # number of plot columns
  np.p <- np.row * np.col # number of plots per page
  par(mfcol=c(np.row, np.col))
  my.col <- 1:100
  my.col[7] <- "blue"
  icount <- 0
  for (i in 1:ny){
    data <- res[[i]]
    if (!is.na(res$est.Sinclair.Z[i,1])){
      icount <- icount + 1
      n.coh <- length(unique(data$cohort))
      i.coh <- (data$cohort-min(data$cohort, na.rm=T)+1)
      plot(data$Age,data$lnVal,pch=i.coh,col=my.col[i.coh],xlab="Age",ylab="ln Val")
      title(main=paste0("Years ",min(data$Year)," to ",max(data$Year),"\nZ = ",round(res$est.Sinclair.Z[i,1],3)), outer=F)
      for (j in 1:n.coh){
        subcoh <- data[i.coh == j,]
        if (length(subcoh$lnVal) >= 2){
          lines(subcoh$Age,subcoh$pred,col=my.col[j],lty=j)
        }
      }
      if(save.plots == T & (icount %% np.p) == 0){
        savePlot(paste0(od,regress.name,"_",i,".",plotf), type=plotf)
      }
    }
    if (save.plots == TRUE & i == ny) savePlot(paste0(od,regress.name,"_",i,".",plotf), type=plotf)
  }
  par(mfcol=c(1,1))

  # plot the distribution of residuals by age
  if (!all(is.na(est.Z))){
    resids <- matrix(NA, nrow=0, ncol=2)
    colnames(resids) <- c("Age","Resid")
    for (i in 1:ny){
      if (!is.na(res$est.Sinclair.Z[i,1])){
        data <- res[[i]]
        resids <- rbind(resids,cbind(data$Age,data$resid))
      }
    }
    boxplot(resids[,2] ~ resids[,1],xlab="Age",ylab="Residual")
    abline(h=0, col="red", lty=2)
    if(!is.na(my.title)) title(main=my.title, outer=F)
    if(save.plots) savePlot(paste0(od,resid.name,".",plotf), type=plotf)
  }
  else{
    resids <- NA
  }

  return(resids)
}
#-------------------------------------------------------------------------------------
# function to remove ages from matrix of index catch at age, used by get_Sinclair_Z
drop_partially_selected_ages <- function(mat,sel,sel.start.age,sel.end.age,sel.cutoff){
  sel2 <- sel[sel.start.age:sel.end.age]
  age.col <- 1:length(sel2)
  drop.col <- age.col[sel2 < sel.cutoff]
  if (length(drop.col) > 0) mat[,drop.col] <- NA
  return(mat)
}
#-------------------------------------------------------------------------------
#' Get Sinclair Z
#'
#' Set of functions to prepare index matrices and compute and plot Sinclair Z. Estimate Z from catch curves using 4 year moving window with cohort-specific coefficients. Based on Sinclair 2001 ICES J Mar Sci 58: 1-10. Note hard wired to use only ages that are at least 90 percent selected.
#' @param asap name of the variable that read in the asap.rdat file
#' @param a1 list file produced by grab.aux.files function
#' @param index.names names of indices
#' @param save.plots save individual plots
#' @param od output directory for plots and csv files
#' @param plotf type of plot to save
#' @export

get_Sinclair_Z <- function(asap,a1,index.names,save.plots,od,plotf){
  asap.name <- a1$asap.name
  index.mats <- ConvertSurveyToAtAge(asap)
  nages <- asap$parms$nages
  Sinclair.Z <- NA
  for (j in 1:length(index.mats$ob)){
    if (asap$control.parms$index.age.comp.flag[j] == 1){  # used age composition for the index
      mat <- index.mats$ob[[j]]
      sel.start.age <- asap$control.parms$index.sel.start.age[j]
      sel.end.age <- asap$control.parms$index.sel.end.age[j]
      mat <- drop_partially_selected_ages(mat,asap$index.sel[j,],sel.start.age,sel.end.age,0.90)
      if (sel.end.age == nages) mat[,length(mat[1,])] <- NA # drop oldest age because plus group in ASAP
      Sinclair.Z <- calc_Sinclair_Z(mat)
      if (Sinclair.Z$error == FALSE){
        est.Z.name <- paste0("Sinclair_Z_estimates_index_",j)
        regress.name <- paste0("Sinclair_Z_regress_index_",j)
        resid.name <- paste0("Sinclair_Z_resids_index_",j)
        resids <- plot_Sinclair_Z(Sinclair.Z,est.Z.name,regress.name,resid.name,index.names[j],
                                  save.plots,od,plotf)
        Sinclair.Z.table <- cbind(Sinclair.Z$plot.year,Sinclair.Z$est.Sinclair.Z)
        write.csv(Sinclair.Z.table, file=paste0(od,"Sinclair_Z_index_",j,"_",asap.name,".csv"), row.names=F)
      }
    }
  }
  return(Sinclair.Z)
}


# Example : 1   Chapter : 8.3     Page No: 432
# Positive Markov matrix Application.
A<-matrix(c(0.8,0.2,0.05,0.95),ncol=2)
u0<-c(0.02,0.98)
u1<-A%*%u0
print(u1)
u2<-A%*%u1
print(u2)


#######################
## Section 6, Part 1 ##
#######################

#install.packages("pglm")
#install.packages("mlogit")
#install.packages("statmod")

library(pglm)
library(mlogit)
library(statmod)
library(MASS)

setwd("C:\\dc_book\\Replication_Files_Element")

Scot.panel <- read.csv("Scottish_Ref.csv")

# scotReferendumIntention 1 = leave, 0 = stay
# euRefVote 1 = stay, 0 = leave (reverse coded from original survey question)

###############
## Table 6.1 ##
###############

# quadrature
re.logit.quad <- pglm(scotReferendumIntention ~ euRefVote+postEUref+postEUVote+satDemScot+riskUnemployment+Scottish, model=("random"), effect=("individual"), R=64, index=c("id", "wave"), family=binomial(link="logit"), data=Scot.panel)
re.logit.quad.results <- cbind(re.logit.quad$estimate, sqrt(diag(vcov(re.logit.quad))), confint.default(re.logit.quad, level=0.95))
N <- length(unique(Scot.panel$id))
O <- nrow(Scot.panel)
colnames(re.logit.quad.results) <- c("Coeff", "(se)", "2.5%", "97.5%")
print((round(re.logit.quad.results, digits=3)))
print(N)
print(O)

# simulation

Scot.panel.long <- mlogit.data(Scot.panel, choice="scotReferendumIntention", shape="wide", id="id")
Scot.panel.long$constant <- as.numeric(as.character(Scot.panel.long$alt))
re.logit.sim <- mlogit(scotReferendumIntention ~ constant | 0+euRefVote+postEUref+postEUVote+satDemScot+riskUnemployment+Scottish, rpar=c(constant='n'), panel=TRUE, index="id", R=500, data=Scot.panel.long, reflevel="0")
re.logit.sim.results <- cbind(re.logit.sim$coefficients, sqrt(diag(vcov(re.logit.sim))), confint.default(re.logit.sim, level=0.95))
N <- length(unique(Scot.panel$id))
O <- nrow(Scot.panel)
colnames(re.logit.sim.results) <- c("Coeff", "(se)", "2.5%", "97.5%")
print((round(re.logit.sim.results, digits=3)))
print(N)
print(O)

# logit

pooled.logit <- glm(scotReferendumIntention ~ euRefVote+postEUref+postEUVote+satDemScot+riskUnemployment+Scottish, family=binomial(link="logit"), data=Scot.panel)
pooled.logit.results <- cbind(pooled.logit$coefficients, sqrt(diag(vcov(pooled.logit))), confint.default(pooled.logit, level=0.95))
N <- length(unique(Scot.panel$id))
O <- nrow(Scot.panel)
colnames(pooled.logit.results) <- c("Coeff", "(se)", "2.5%", "97.5%")
print((round(pooled.logit.results, digits=3)))
print(N)
print(O)

################
## Figure 6.1 ##
################

beta.re <- re.logit.quad$estimate
beta.re0 <- re.logit.quad$estimate[-grep("sigma", names(re.logit.quad$estimate))]
beta.pooled <- pooled.logit$coefficients

ndraws <- 1000
beta <- re.logit.quad$estimate
covmat.beta <- vcov(re.logit.quad)
betadraw <- mvrnorm(ndraws, beta, covmat.beta)

betadraw.pooled <- mvrnorm(ndraws, beta.pooled, vcov(pooled.logit))
betadraw.re0 <- as.matrix(betadraw[,-grep("sigma", names(re.logit.quad$estimate))])

baseline.x <- with(Scot.panel, data.frame(
constant = 1,
euRefVote = median(euRefVote),
postEUref = median(postEUref),
postEUVote = median(postEUVote),
satDemScot = median(satDemScot),
riskUnemployment = median(riskUnemployment),
Scottish = median(Scottish)
))

satdemcol <- grep("satDemScot", colnames(baseline.x))
satdem.range <- seq(0, 5, 0.1)

probs.re <- matrix (0, ndraws, length(satdem.range))
probs.re0 <- matrix (0, ndraws, length(satdem.range))
probs.pooled <- matrix (0, ndraws, length(satdem.range))

probs.mean <- matrix(0, length(satdem.range), 3)

R <- 64
# the command "gauss.quad.prob" gives the "probabilist" version of the Hermite polynomial (the command "gauss.quad" gives the "physicist" version)
quadpoints <- gauss.quad.prob(R, dist="normal")
intpoints <- quadpoints$nodes
intweights <- quadpoints$weights

for (i in 1:length(satdem.range)) {

	baseline.x[satdemcol] <- satdem.range[i]

	for (j in 1:length(intpoints)) {

		x.re <- cbind(baseline.x, intpoints[j])
		p.re <- plogis(beta.re %*% t(x.re)) * intweights[j]
		probs.mean[i,1] <- probs.mean[i,1] + p.re

		p.draw.re <- plogis(betadraw %*% t(x.re)) * intweights[j]
		probs.re[,i] <- probs.re[,i] + p.draw.re
	}

	probs.mean[i,2] <- plogis(beta.pooled %*% t(baseline.x))
	probs.mean[i,3] <- plogis(beta.re0 %*% t(baseline.x))

	probs.pooled[,i] <- plogis(betadraw.pooled %*% t(baseline.x))
	probs.re0[,i] <- plogis(betadraw.re0 %*% t(baseline.x))

}

# random effects, pooled logit, random effect (v=0)
colors <- c("#FC660080", "#004D7380", "#86AC4180")

pdf("fig61.pdf")
par(mar=c(5.1, 4.1, 4.1, 5.5), mgp=c(2.5, 1, 0), cex.lab=1.5)
plot(probs.mean[,1] ~ satdem.range, xlim=c(1,4), ylim=c(0, 1), type="n", xaxt="n", xlab="Satisfaction with Democracy", ylab="Probability", xaxt="n", las=1)
axis(1, at=c(1, 2, 3, 4))
for (i in 1:length(satdem.range)){
	points(probs.re[i,] ~ satdem.range, type="l", col=colors[1], lwd=1)
	points(probs.pooled[i,] ~ satdem.range, type="l", col=colors[2], lwd=1)
	points(probs.re0[i,] ~ satdem.range, type="l", col=colors[3], lwd=1)
}
lines(probs.mean[,1]~satdem.range, col=rgb(0,0,0,0.5), lwd=2)
lines(probs.mean[,2]~satdem.range, col=rgb(0,0,0,0.5), lwd=2)
lines(probs.mean[,3]~satdem.range, col=rgb(0,0,0,0.5), lwd=2)
mtext("Random", side=4, at=probs.mean[42,1] + 0.035, cex=1.1, las=1, line=0.5)
mtext("Effects", side=4, at=probs.mean[42,1], cex=1.1, las=1, line=0.5)
mtext("Logit", side=4, at=(probs.mean[42,1] - 0.035), cex=1.1, las=1, line=0.5)
mtext("Pooled Logit", side=4, at=probs.mean[42,2], cex=1.1, las=1, line=0.5)
mtext("Random", side=4, at=probs.mean[42,3]+0.035, cex=1.1, las=1, line=0.5)
mtext("Effects", side=4, at=probs.mean[42,3], cex=1.1, las=1, line=0.5)
mtext(expression(paste("Logit (", alpha," = 0)", sep="")), side=4, at=(probs.mean[42,3] - 0.035), cex=1.1, las=1, line=0.5)
dev.off()

###############
## Table 6.2 ##
###############

ndraws <- 1000
beta <- re.logit.quad$estimate
covmat.beta <- vcov(re.logit.quad)
betadraw <- mvrnorm(ndraws, beta, covmat.beta)

baseline.x <- with(Scot.panel, data.frame(
constant = 1,
euRefVote = median(euRefVote),
postEUref = median(postEUref),
postEUVote = median(postEUVote),
satDemScot = median(satDemScot),
riskUnemployment = median(riskUnemployment),
Scottish = median(Scottish)
))

x.remain.pre <- baseline.x
x.remain.pre[names(x.remain.pre)=="euRefVote"] <- 1
x.remain.pre[names(x.remain.pre)=="postEUref"] <- 0
x.remain.pre[names(x.remain.pre)=="postEUVote"] <- 0

x.remain.post <- baseline.x
x.remain.post[names(x.remain.post)=="euRefVote"] <- 1
x.remain.post[names(x.remain.post)=="postEUref"] <- 1
x.remain.post[names(x.remain.post)=="postEUVote"] <- 1

x.leave.pre <- baseline.x
x.leave.pre[names(x.leave.pre)=="euRefVote"] <- 0
x.leave.pre[names(x.leave.pre)=="postEUref"] <- 0
x.leave.pre[names(x.leave.pre)=="postEUVote"] <- 0

x.leave.post <- baseline.x
x.leave.post[names(x.leave.post)=="euRefVote"] <- 0
x.leave.post[names(x.leave.post)=="postEUref"] <- 1
x.leave.post[names(x.leave.post)=="postEUVote"] <- 0

probs <- matrix(0, ndraws, 7)

## quadrature
R <- 64

quadpoints <- gauss.quad.prob(64, dist="normal")
intpoints <- quadpoints$nodes
intweights <- quadpoints$weights

## could use simulation instead
#install.packages("randtoolbox")
#library(randtoolbox)
#R <- 250
#halton.seq <- halton(R)
#intpoints <- qnorm(halton.seq)
#intweights <- rep(1/R, R)

for (i in 1:R) {

	x.remain.pre.q <- cbind(x.remain.pre, intpoints[i])
	x.remain.post.q <- cbind(x.remain.post, intpoints[i])
	x.leave.pre.q <- cbind(x.leave.pre, intpoints[i])
	x.leave.post.q <- cbind(x.leave.post, intpoints[i])

	p.remain.pre <- plogis(betadraw %*% t(x.remain.pre.q)) * intweights[i]
	p.remain.post <- plogis(betadraw %*% t(x.remain.post.q)) * intweights[i]
	p.leave.pre <- plogis(betadraw %*% t(x.leave.pre.q)) * intweights[i]
	p.leave.post <- plogis(betadraw %*% t(x.leave.post.q)) * intweights[i]

	probs[,1] <- probs[,1] + p.remain.pre
	probs[,2] <- probs[,2] + p.remain.post
	probs[,3] <- probs[,3] + p.leave.pre
	probs[,4] <- probs[,4] + p.leave.post

}

probs[,5] <- probs[,2] - probs[,1]
probs[,6] <- probs[,4] - probs[,3]
probs[,7] <- probs[,5] - probs[,6]

all.results <- probs
quantiles <- apply(all.results, 2, function(x) {quantile(x, probs=c(0.5, 0.025, 0.975))})
sds <- apply(all.results, 2, sd)
first.differences <- cbind(t(quantiles), sds)
colnames(first.differences) <- c("Median", "2.5%", "97.5%", "(se)")
rownames(first.differences) <- c("Remain: Pre Brexit", "Remain: Post Brexit", "Remain: Difference", "Leave: Pre Brexit", "Leave: Post Brexit", "Leave: Difference", "Diff in Diff")
print(round(first.differences, digits=3))

###############
## Table 6.3 ##
###############

ndraws <- 1000
beta <- re.logit.quad$estimate
covmat.beta <- vcov(re.logit.quad)
betadraw <- mvrnorm(ndraws, beta, covmat.beta)

R <- 64
quadpoints <- gauss.quad.prob(R, dist="normal")
intpoints <- quadpoints$nodes
intweights <- quadpoints$weights

observed.x <- with(Scot.panel, data.frame(
constant = 1,
euRefVote = euRefVote,
postEUref = postEUref,
postEUVote = postEUVote,
satDemScot = satDemScot,
riskUnemployment = riskUnemployment,
Scottish = Scottish
))

mean.x <- colMeans(observed.x)

id.weights <- Scot.panel$sample_weight

mem <- 0
ame.all <- matrix(0, nrow(betadraw), nrow(observed.x))

mem.predprob <- matrix(0, nrow(betadraw), 1)
ame.predprob <- matrix(0, nrow(betadraw), nrow(observed.x))

for (i in 1:R) {

	# MEM
	x.mean.all <- cbind(t(mean.x), intpoints[i])
	predprob.mean <- plogis(betadraw %*% t(x.mean.all))
	predprob.mean.q <- predprob.mean * intweights[i]
	mem.predprob <- mem.predprob + (predprob.mean.q)
	mem.temp <- predprob.mean * (1 - predprob.mean) * betadraw[,"satDemScot"]
	mem <- mem + (mem.temp * intweights[i])

	# AME
	x.vars.all <- cbind(observed.x, intpoints[i])
	predprobs <- plogis(betadraw %*% t(x.vars.all))
	ame.predprob <- ame.predprob + (predprobs * intweights[i])
	ame.temp <- predprobs * (1 - predprobs) * betadraw[,"satDemScot"]
	ame.all <- ame.all + (ame.temp * intweights[i])

}

ame <- colSums(apply(ame.all, 1, function(x){x * id.weights}))/sum(id.weights)
elas <- t(ame.all) * observed.x[,"satDemScot"] * t(1/ame.predprob)
avg.elas <- colSums(apply(elas, 2, function(x){x * id.weights}))/sum(id.weights)
mem.elas <- mem * (mean.x["satDemScot"]/mem.predprob)

all.results <- cbind(ame, mem, avg.elas, mem.elas)
quantiles <- apply(all.results, 2, function(x) {quantile(x, probs=c(0.5, 0.025, 0.975))})
sds <- apply(all.results, 2, sd)
marginal.effects <- cbind(t(quantiles), sds)
colnames(marginal.effects) <- c("Median", "2.5%", "97.5%", "(se)")
rownames(marginal.effects) <- c("AME", "MEM", "Average Elasticity", "Elasticity at the Mean")
print(round(marginal.effects, digits=3))

###############
## Table 6.4 ##
###############

## Population Odds Ratios

ndraws <- 1000
beta <- re.logit.quad$estimate
covmat.beta <- vcov(re.logit.quad)
betadraw <- mvrnorm(ndraws, beta, covmat.beta)

R <- 64
quadpoints <- gauss.quad.prob(R, dist="normal")
intpoints <- quadpoints$nodes
intweights <- quadpoints$weights

observed.x <- with(Scot.panel, data.frame(
Intercept = 1,
euRefVote = euRefVote,
postEUref = postEUref,
postEUVote = postEUVote,
satDemScot = satDemScot,
riskUnemployment = riskUnemployment,
Scottish = Scottish
))

id.weights <- Scot.panel$sample_weight

OR.pop <- matrix(NA, ncol(observed.x), 4)

p.0 <- matrix(0, nrow(betadraw), nrow(observed.x))

# calculate baseline
for (j in 1:R) {

	x.vars.all <- cbind(observed.x, intpoints[j])
	p0 <- plogis(betadraw %*% t(x.vars.all))
	p.0 <- p.0 + (p0 * intweights[j])

}

# increment each variable by 1, calculate odds ratios
for (i in 1:ncol(observed.x)) {

	p.1 <- matrix(0, nrow(betadraw), nrow(observed.x))
	observed.x1 <- observed.x
	observed.x1[,i] <- observed.x1[,i] + 1

	if (i==4) {
	observed.x1[,2] <- observed.x1[,2] + 1
	observed.x1[,3] <- observed.x1[,3] + 1
	}

	for (j in 1:length(intpoints)) {

		x1.vars.all <- cbind(observed.x1, intpoints[j])
		p1 <- plogis(betadraw %*% t(x1.vars.all))
		p.1 <- p.1 + (p1 * intweights[j])

	}

		OR.temp <- (p.1 / (1 - p.1)) / (p.0 / (1 - p.0))
		OR.temp.w <- colSums(apply(OR.temp, 1, function(x){x * id.weights}))/sum(id.weights)
		OR.pop[i,1:3] <- quantile(OR.temp.w, probs=c(0.5, 0.025, 0.975))
		OR.pop[i,4] <- sd(OR.temp)

}

N <- length(unique(Scot.panel$id))
O <- nrow(Scot.panel)
colnames(OR.pop) <- c("Median", "2.5%", "97.5%", "(se)")
rownames(OR.pop) <- names(observed.x)
print((round(OR.pop, digits=3)))
print(N)
print(O)

## Subject-Specific Odds ratios

betadraw.or <- betadraw[,-grep("sigma|(Intercept)|postEUVote", colnames(betadraw))]
postEUVote <- betadraw[,grep("euRefVote", colnames(betadraw))] + betadraw[,grep("postEUref", colnames(betadraw))] + betadraw[,grep("postEUVote", colnames(betadraw))]
betadraw.or <- cbind(betadraw.or, postEUVote)

exp.betadraw <- exp(betadraw.or)
N <- length(unique(Scot.panel$id))
O <- nrow(Scot.panel)
quantiles <- apply(exp.betadraw, 2, function(x) {quantile(x, probs=c(0.5, 0.025, 0.975))})
sds <- apply(exp.betadraw, 2, sd)
odds.ratios <- cbind(t(quantiles), sds)
colnames(odds.ratios) <- c("Median", "2.5%", "97.5%", "(se)")
rownames(odds.ratios) <- colnames(exp.betadraw)
print(round(odds.ratios, digits=3))
print(N)
print(O)

## approximation from Zeger et al. 1988, p. 1054 ##

c <- ((16*sqrt(3))/(15*pi))
scale.pa <- sqrt(1 + c^2 * re.logit.quad$estimate[grep("sigma", names(re.logit.quad$estimate))]^2)
beta.Zeger <- apply(betadraw.or, 2, function(x){x/scale.pa})
exp.beta.Zeger <- exp(beta.Zeger)
quantiles.Zeger <- apply(exp.beta.Zeger, 2, function(x) {quantile(x, probs=c(0.5, 0.025, 0.975))})
sds.Zeger <- apply(exp.beta.Zeger, 2, sd)
Zeger.adj <- cbind(t(quantiles.Zeger), sds.Zeger)
colnames(Zeger.adj) <- c("Median", "2.5%", "97.5%", "(se)")
rownames(Zeger.adj) <- colnames(exp.beta.Zeger)
print(round(Zeger.adj, digits=3))

## approximation from Hedeker et al. 2018 ##

betadraw.H <- betadraw[,-grep("sigma|postEUVote", colnames(betadraw))]
postEUVote <- betadraw[,grep("euRefVote", colnames(betadraw))] + betadraw[,grep("postEUref", colnames(betadraw))] + betadraw[,grep("postEUVote", colnames(betadraw))]
sigma <- betadraw[,grep("sigma", colnames(betadraw))]
betadraw.H <- cbind(betadraw.H, postEUVote, sigma)

observed.H <- with(Scot.panel, data.frame(
Intercept = 1,
euRefVote = euRefVote,
postEUref = postEUref,
satDemScot = satDemScot,
riskUnemployment = riskUnemployment,
Scottish = Scottish,
postEUVote = postEUVote
))

predprobs <- matrix(0, nrow(betadraw.H), nrow(observed.H))

for (i in 1:R) {

	x.vars.all <- cbind(observed.H, intpoints[i])
	predprobs.temp <- plogis(betadraw.H %*% t(x.vars.all))
	predprobs <- predprobs + (predprobs.temp * intweights[i])

}

X <- as.matrix(observed.H)
lambda.matrix <- log(predprobs/(1 - predprobs))
beta.Hedeker <- apply(lambda.matrix, 1, function(x){solve(t(X) %*% X) %*% (t(X) %*% x)})
exp.beta.Hedeker <- exp(beta.Hedeker)
quantiles.Hedeker <- apply(exp.beta.Hedeker, 1, function(x) {quantile(x, probs=c(0.5, 0.025, 0.975))})
sds.Hedeker <- apply(exp.beta.Hedeker, 1, sd)
Hedeker.adj <- cbind(t(quantiles.Hedeker), sds.Hedeker)
colnames(Hedeker.adj) <- c("Median", "2.5%", "97.5%", "(se)")
rownames(Hedeker.adj) <- colnames(observed.H)
Hedeker.adj <- Hedeker.adj[-1,]  # remove constant term
print(round(Hedeker.adj, digits=3))


# This offline tool is a new method to identify the vent location of tephra fall deposits
# based on thickness or maximum clast size measurements.
# It is temporarily named "svl", which is short for Source Vent Locator.
# This file includes the associated R functions and their notations.

###
# Since the presented method gives estimate on the vent location and prevailing wind
# direction, it can be used to produce the input for our method to model the thickness
# or maximum clast size distribution of
# tephra fall deposits (Yang and Bursik, 2016; https://vhub.org/resources/3957).
###
# Author: Qingyuan Yang, Marcus Bursik, and E. Bruce Pitman.
###
# License: GPL. Use at your own risk.
###
# The work was supported by National Science Foundation Hazard SEES grant number 1521855 to
# G. Valentine, M. Bursik, E.B. Pitman and A.K. Patra, and National Science Foundation
# DMS grant number 1621853 to A.K. Patra, M. Bursik, and E.B. Pitman.
###
# We appreciate your comments, suggestions, and feedback.
# Please feel free to contact us through vhub or email: qyang5@buffalo.edu
# Notes:
#	The functions below are the version of the method that is coupled with the semi-
#	empirical model proposed by Gonzalez-Mellado and De la Cruz-Reyna (2010).
###### Functions ######
#################################Intermediate functions#################################
sp_par_cal <- function(obs, sv, wind_dir){
	sv = as.vector(sv)
	zr <- obs[,3]
	xy <- as.matrix(obs[,c(1,2)])
	nr <- nrow(obs)
	sv_matrix <- matrix(ncol=2, nrow=nr)
	sv_matrix[,1] <- rep(sv[1], nr)
	sv_matrix[,2] <- rep(sv[2], nr)
	unit_vector <- as.matrix(c(sin(wind_dir*pi/180),cos(wind_dir*pi/180)))
	rel_xy <- xy - sv_matrix
	dist <- (rel_xy[,1]^2 + rel_xy[,2]^2)^0.5
	dd <- (rel_xy) %*% (unit_vector)
	cd <- (dist^2 - dd^2)^0.5
	output <- matrix(nrow = nr, ncol=7)
	output[,1:2] <- xy
	output[,3:5] <- cbind(dist, dd, cd)
	output[,6] <- dist - dd
	output[,7] <- zr
	return(output)
}

fi <- function(obs, sv, wind_dir){
	td <- as.data.frame(sp_par_cal(obs, sv, wind_dir))
	colnames(td) <- c("x","y","dist","dd","cd", "dif","zr")
	td$z = log10(td$zr)

      	fit.res <- lm(z~dif+log(dist),data=td)		# ***case 1: power-law model***
#    	fit.res <- lm(z~dist+dd,data=td)		# ***case 2: exponential model***
        ssr <- sum(fit.res$residuals^2)
	return(ssr)
}

fi2 <- function(obs, sv, wind_dir){
	td <- as.data.frame(sp_par_cal(obs, sv, wind_dir))
	colnames(td) <- c("x","y","dist","dd","cd", "dif","zr")
	td$z = log10(td$zr)
      	fit.res <- lm(z~dif+log(dist),data=td)		# ***case 1: power-law model ***
#       fit.res <- lm(z~dist+dd,data=td)		# ***case 2: exponential model***
     	ssr <- sum(fit.res$residuals^2)
	return(c(ssr, fit.res$coefficients, summary(fit.res)$r.squared))
}

cg <- function(sv, h){
	output  = cbind(c(rep(sv[,1],4)+sin(0:3*90*pi/180)*h),
		    c(rep(sv[,2],4)+cos(0:3*90*pi/180)*h))
	return(output)
}

baf_pre <- function(sv, obs, nlps){
	pot_ang <- as.data.frame((1:36)*10)
	pot_ssr <- apply(pot_ang, MARGIN = 1, FUN=fi, obs = obs, sv = sv)
	lowest_rank = which(rank(pot_ssr)==1)			# ***Power-law***
	next_lowest_rank = which(rank(pot_ssr)==2)		# ***Power-law***
	#lowest_rank = min(which(rank(pot_ssr)<2))				# ***exponential***
	#next_lowest_rank = min(which(rank(pot_ssr)<4 & rank(pot_ssr)>2))	# ***exponential***
	if(abs(lowest_rank - next_lowest_rank)==1 || abs(lowest_rank - next_lowest_rank)==35){
		return(c(1, pot_ang[lowest_rank,1]))
	}else{
		return(c(2, pot_ang[lowest_rank,1], pot_ang[next_lowest_rank, 1]))
	}
}

baf_processor <- function(sv, obs, nlps, proposed_winddir){
	fdm <- matrix(c(-1,0,1,-1,0,1), nrow=2)
	h <- 5
	warns <- 0
	resm <- data.frame(matrix(ncol=2,nrow=2))
	gdnt <- c()
	wind_dir = proposed_winddir
	res <- fi(obs, sv, wind_dir)
	resm[1,1] <- wind_dir
	resm[1,2] <- res[1]
	wind_dir <- wind_dir + h
	res <- fi(obs, sv, wind_dir)
	resm[2,1] <- wind_dir
	resm[2,2] <- res[1]
	if(resm[1,2] >= resm[2,2]){
		lid <- 1
	}else{
		lid <- -1
	}
	r = 1
	for(i in 3:nlps){
		if(lid == 1){
			wind_dir <- resm[order(resm[,2]),][1,1] + h
			lid <- 1
		}else if(lid == -1){
			wind_dir <- resm[order(resm[,2]),][1,1] - 2 * h
			lid <- -1
		}else if(lid == 0 && r == 1){
			h <- h * 0.4
			wind_dir <-resm[order(resm[,2]),][1,1] + h
			r = 0
		}else if(lid == 0 && r == 0){
			wind_dir <-resm[order(resm[,2]),][1,1] - h
			r = 1
		}

		res <- fi(obs, sv, wind_dir)
		resm[i,1] <- wind_dir
		resm[i,2] <- res[1]
		resm <- resm[order(resm[,1]),]
			if(lid == 1){
				gdnt <-  fdm %*% resm[c(i-2,i-1,i),2]
			}
			if(lid == -1){
				gdnt <- fdm %*% resm[c(1,2,3),2]
			}
			if(lid == 0 ){
				n <- which(resm[,2]==min(resm[,2]))
				gdnt <- fdm %*% resm[c(n-1,n, n+1) ,2]
			}
		if(gdnt[1]<0 && gdnt[2]>=0){lid <- 0}
		if(gdnt[1]>=0 && gdnt[2] >= 0){lid <- -1}
		if(gdnt[1]<0 && gdnt[2] <0){lid <- 1}
		if(gdnt[1] > 0 && gdnt[2] < 0){lid <- -1}

		if(h < 0.01){break}
	}
	temp <- resm[which(resm[,2]==min(resm[,2])),]
	output <- as.matrix(cbind(temp[1], temp[2]), nrow = 1)
	return(output)

}

baf <- function(sv, obs, nlps){
	raw_inference <- baf_pre(sv, obs, nlps)
	if(raw_inference[1] == 1){
		output = baf_processor(sv, obs, nlps, raw_inference[2])
		return(output)
	}else{
		output_1 = baf_processor(sv, obs, nlps, raw_inference[2])
		output_2 = baf_processor(sv, obs, nlps, raw_inference[3])
		if(output_1[2]<output_2[2]){return(output_1)}else{return(output_2)}
	}
}

compare <- function(sv, obs, h, nlps, h_ratio){
	rsm <- (cg(sv, h*h_ratio))
	cr <- baf(sv, obs, nlps)
	rr = t(apply(X = rsm,  MARGIN = 1, FUN = baf, obs = obs, nlps = nlps))
	first_order_grad <- rr[,2]-cr[2]
	if(min(first_order_grad>0)){
		return(1)
	}else{
		first_order_grad[first_order_grad > 0] = 0
		direction = c(1,1,-1,-1)
		grad_y = (-1*direction[c(1,3)])%*%first_order_grad[c(1,3)]
		grad_x = (-1*direction[c(2,4)])%*%first_order_grad[c(2,4)]
		grad_unit = c(grad_x/(grad_x^2+grad_y^2)^0.5, grad_y/(grad_x^2+grad_y^2)^0.5)
		return(c(2,grad_unit))
	}
}
####################End of intermediate functions#################################

#################### Function name: gd_simplified ####################
gd_simplified <- function(sv, obs, runs, h, r, nlps, h_ratio, numb){
 obs = obs[numb,]
	tcoord <- as.data.frame(matrix(ncol=2))
	dec <- c()
	hl <- c()
	ihd <- h
	ir=1
	jg <- 0
	warns <- 0
	for(i in 1:runs){
			dec <- compare(sv, obs, h, nlps, h_ratio)
			if(dec[1]!= 1 && jg ==0){
					sv <- sv + h*dec[2:3]
					tcoord[i,] <- sv
					hl[i] <- h
					jg <- 0
			}else if(dec[1] != 1 && jg == 1){
					h <- h *(1 - r)
					sv <- sv + h*dec[2:3]
					tcoord[i,] <- sv
					hl[i] <- h
					jg <- 0
			}else if(dec[1] == 1 && h/ihd >= 0.0001){
				h = h * r
				hl[i] <- h
				jg <- 1
			}
		if(h < 0.1){break}
	}
	bd <- baf(sv, obs, nlps)
	rownames(tcoord) <- NULL
	output_sv = tcoord[nrow(tcoord),]
	output_ang = bd[1]
	fitted_results= fi2(obs, as.matrix(sv), output_ang)
	return(as.matrix(cbind(sv, output_ang, h, coef = t(fitted_results[c(2,3,4)]), ssr = fitted_results[1], rsquare = fitted_results[5])))
}

########################################## End of functions #####################################################

# Reference:
#	Gonzalez-Mellado, A. O., and S. De la Cruz-Reyna. "A simple semi-empirical approach to model thickness of
# ash-deposits for different #eruption scenarios." Natural Hazards and Earth System Sciences 10.11 (2010): 2241.
# 	Yang Q, Bursik M. A new interpolation method to model thickness, isopachs, extent, and volume of tephra fall
# deposits. Bulletin of Volcanology, 2016, 78(10): 68.


# Negative log-likelihood component for the tag-recapture data
# (using Gauss-Hermite quadrature) and assuming a lognormal distn for A.

# Assumes data is in a matrix with columns: l1, l2, t1, t2, measr
# where l1=release length
#       l2=recapture length
#       t1=release time (in julian time since Jan 1 of reference year)
#       t2=recapture time (in julian time since Jan 1 of reference year)
#       measr=0 if recapture length measured by a scientist
#            =1 if recapture length measured by a fisherman

# Assumes parameters are: mu.L, sig.L, param.f, mu.logA, sig.logA, sig.s, sig.f
# where param.f is parameters of growth function, mu.logA and sig.logA are
# parameters of the log normal distribution for A, sig.s is the error variance
# for scientists, and sig.f is the error variance for fisherman.

# The log density of the age-at-tagging  must be specified in a function
# logdensA.f(a,param.A)

# The errors are specified in the function error.ssnl.f

            #------------------------------------------------#

log.lognormA.f<- function(a,param.A)
{   # the log density of the tagging age A
    # A log-normal
    alpha.A<- param.A[1]
    beta.A<-  param.A[2]

    # a is nf x n matrix
    lna<- a
    tf<- a>0

    lna[tf]<- log(a[tf])
    lna[!tf]<- -300

    logpa<- (lna-alpha.A)/beta.A
    logpa<- -0.5*log(2*pi)-log(beta.A)-lna-0.5*logpa^2
    return(logpa)
}

lognormA.f<- function(a,param.A)
{# dlnorm only takes vectors for the first argument
    veca<- as.vector(a)

    alpha.A<- param.A[1]
    beta.A<-  param.A[2]

    tf<- a <= 0
    a[tf]<- exp(-30)

    pa<- dlnorm(veca,alpha.A,beta.A)
    pa<- matrix(pa,nrow=nrow(a),ncol=ncol(a),byrow=F)
    return(pa)
}

# The function logdensA.f() is changed if a new distribution for
# A is tried
logdensA.f<- log.lognormA.f
densA.f<-lognormA.f

error.ssnl.f<- function(capstatus,measr,param.sig)
{   # -this gives the additive error structure of the model
    # -capstatus = "release" or "recapture"
    # -measr = 0 if a scientist measured the recapture length
    #       = 1 if a fisherman measured the recapture length

    sig.s<- param.sig[1]   # s.d. for a scientiest
    sig.f<- param.sig[2]   	# this is the additional error for fishermen
    if(capstatus=="release")
       {sigma<- sig.s}
    if(capstatus=="recapture")
       {sigma<- sig.s+sig.f*measr}
    return(sigma)
}

ha.ssnl.f<- function(a,tagdat,param.g,param.sig)
{   # this calculates h(l1,l2|a)
    # it is needed as part of int.f

    # a is nf x n matrix
    tf<- a<0
    a[tf]<-0

    h<- exp(logha.ssnl.f(a,tagdat,param.g,param.sig))
    return(h)
}

logha.ssnl.f<- function(a,tagdat,param.g,param.sig)
{   # this calculates log h(l1,l2|a)
    # it is needed as part of logint.f

    # a is nf x n matrix
    tf<- a<0
    a[tf]<-0

    # retrieve the data
    l1<- tagdat[,1]
    l2<- tagdat[,2]
    t1<- tagdat[,3]
    t2<- tagdat[,4]
    measr<- tagdat[,5]

    # retrieve the growth curve parameters
    mu.L<-    param.g[1]
    sigma.L<- param.g[2]
    param.f<- param.g[3:length(param.g)]

    ucol<- matrix(1,nrow=nrow(a),ncol=1)
    urow<- matrix(1,nrow=1,ncol=ncol(a))

    a2<- a+(t2-t1)%*%urow
    f1<- growth.ssnl.f(a,param.f,t1-floor(t1))
    f2<- growth.ssnl.f(a2,param.f,t2-floor(t2))
    sigma1<- error.ssnl.f("release",measr,param.sig)
    sigma2<- error.ssnl.f("recapture",measr,param.sig)
    mu1a<- mu.L*f1
    mu2a<- mu.L*f2
    var1a<- (sigma.L*f1)^2 + sigma1^2
    var2a<- (sigma.L*f2)^2 + sigma2^2
    s12<- sqrt(var1a*var2a)
    rhoa<-  (sigma.L^2)*f1*f2/s12
    q1<- l1%*%urow-mu1a
    q2<- l2%*%urow-mu2a
    q12<- q1*q2
    q1<- q1^2/var1a
    q2<- q2^2/var2a
    q12<- q12*rhoa/s12
    q<- q1+q2-2*q12
    logh<- -log(2)-log(pi)-0.5*log(var1a)-0.5*log(var2a)-0.5*log(1-rhoa^2)
    rho<- 2*(1-rhoa^2)
    logh<- logh-q/rho
    return(logh)
}

int.ssnl.f<- function(a,tagdat,param.g,param.A,param.sig)
{   # this calculates h(l1,l2|a) p(a)
    # so that later it can be integrated
    #
    # a is a nf x n matrix, where nf=nrow(tagdat)

    pa<- densA.f(a,param.A)
    integrand<- ha.ssnl.f(a,tagdat,param.g,param.sig)*pa
    return(integrand)
}

logint.ssnl.f<- function(a,tagdat,param.g,param.A,param.sig)
{   # this calculates  -log[h(l1,l2|a) p(a)]
    # it is used in the grid search or golden section search
    # for the mode of h(l1,l2|a) p(a)
    # we search on the log scale because the log is more
    # numerically stable
    #
    # a is a nf x n matrix, where nf=nrow(tagdat)
    # tagdat is a nf x 4 matrix of variables l1,l2,t1,t2

    logpa<- logdensA.f(a,param.A)
    logha<- logha.ssnl.f(a,tagdat,param.g,param.sig)
    integrand<- logha+logpa
    return(integrand)
}

h.ssnl.f<- function(tagdat,param.g,param.A,param.sig)
{
    # This calculates  int_-\infty^\infty h(l1,l2|a) p(a) da
    # using 20-point Gauss-Hermite integration

    gms<- gstats.ssnl.f(tagdat,param.g,param.A,param.sig)
    mng<- gms[,1]
    sdg<- gms[,2]
    pdf.l1.l2<- hermite20.f(int.ssnl.f,tagdat,param.g,param.A,
        param.sig,nrow(tagdat),mng,sdg)
    return(pdf.l1.l2)
}

logl.ssnl.f<-function(param,npf,npA,tagdat)
{   # this calculates the negative log likelihood of the data

    npg<- npf+2
    param.g<- param[1:npg]
    param.A<- param[(npg+1):(npg+npA)]
    param.sig<- param[(npg+npA+1):(npg+npA+2)]

    # print(c(param.g, param.A, param.sig))

    ndata<- nrow(tagdat)
    gms<-   gstats.ssnl.f(tagdat,param.g,param.A,param.sig)
    mng<- gms[,1]
    sdg<- gms[,2]
    pdf.l1.l2<- hermite20.f(int.ssnl.f,tagdat,param.g,param.A,
		param.sig,ndata,mng,sdg)
    negloglz<- -sum(log(pdf.l1.l2))
    if(is.na(neglogl)){print(" neglogl NA ")}
    return(neglogl)
}

hermite20.f<- function(f,tagdat,param.g,param.A,param.sig,nf,mu,sigma)
 { # this carries out 20-point Gauss-Hermite integration of f(x)
   # i.e. int_-\infty^\infty f(x) dx
   # it assumes that f(x) is roughly Gaussian with mean mu and s.d. sigma
   # here f is a nfx1 vector of functions, and mu, sigma are nfx1 vectors
   #
   # tagdat is a matrix of data which comprise the second argument of f
   # param is a vector of parameters which comprise the third argument of f
   #
   x<- c(-5.3874808900112,-4.6036824495507,-3.9447640401156,-3.3478545673832,
         -2.7888060584281,-2.2549740020893,-1.7385377121166,-1.2340762153953,
         -0.7374737285454,-0.2453407083009, 0.2453407083009, 0.7374737285454,
      1.2340762153953, 1.7385377121166, 2.2549740020893, 2.7888060584281,
      3.3478545673832, 3.9447640401156, 4.6036824495507, 5.3874808900112)

   wexp<- c(0.8985919614532, 0.7043329611769, 0.6222786961914, 0.5752624428525,
            0.5448517423644, 0.5240803509486, 0.5096790271175, 0.4999208713363,
            0.4938433852721, 0.4909215006667, 0.4909215006667, 0.4938433852721,
        0.4999208713363, 0.5096790271175, 0.5240803509486, 0.5448517423644,
        0.5752624428525, 0.6222786961914, 0.7043329611769, 0.8985919614532)

   rt2<- c(1.414213562373)
   urow<- matrix(1,nrow=1,ncol=20)

   xmat<- rt2*(sigma%*%t(x))+mu%*%urow        # xmat is a nf x 20 matrix
   fx<-    f(xmat,tagdat,param.g,param.A,param.sig)

   intf<-  fx%*%wexp
   intf<- rt2*sigma*intf
   if(sum(is.na(intf))>0){print(" hermite20 NA ")}
   return(intf)
}

gridsch.f<- function(f,l,u,vmat,param.g,param.A,param.sig)
{   # gridsch.f is a grid search
    #
    # l is vector of true lower bounds
    # u is a vector of true upper bounds

    eps1<- 1e-13

    n<- 100
    urow<- matrix(1,nrow=1,ncol=(n+1))
    range<- u-l
    ind<- (0:n)
    x<- range%*%t(ind)
    x<- l%*%urow+x/n
    fx<- f(x,vmat,param.g,param.A,param.sig)
    fmax<- apply(fx,1,max)
    xmax<- fmax%*%urow
    tf<- fx >= xmax - eps1

    # if there are two minima in a row by some extraordinary chance,
    # xmax found in the following line of code will keep both
    # this is undesirable

    # xmax<- as.vector(t(x)[t(tf)])

    # the following piece of code avoids that problem
    rmax<- row(x)[tf]
    cmax<- col(x)[tf]
    tf<- (!duplicated(rmax))
    rmax<- rmax[tf]
    cmax<- cmax[tf]
    ord<- order(rmax)
    rmax<- rmax[ord]
    cmax<- cmax[ord]
    rcmax<- cbind(rmax,cmax)
    xmax<- as.vector(x[rcmax])
    if(min(cmax)==1) {print("maximum on lower bound")
                          print("rows")
                          print(rmax[cmax==1])
                          #browser()
                          cmax[cmax==1]<-2
    }
    if(max(cmax)==ncol(x)) {print("maximum on upper bound")
                          print("rows")
                          print(rmax[cmax==ncol(x)])
                          #browser()
                          cmax[cmax==ncol(x)]<-ncol(x)-1
    }
    rcmax<- cbind(rmax,cmax-1)
    a1<- as.vector(x[rcmax])
    f1<- as.vector(fx[rcmax])
    rcmax<- cbind(rmax,cmax+1)
    a3<- as.vector(x[rcmax])
    f3<- as.vector(fx[rcmax])
    return(cbind(a1,f1,xmax,fmax,a3,f3))
}

quadmax.f<- function(ahdat)
{   # we are attempting to improve the estimate of the location
    # of the maximum of a nearly quadratic function h(a)
    # ahdat = cbind(a1,h1,a2,h2,a3,h3)
    # a1 < a2 < a3
    # h2>h1 and h2>h3

    a1<- ahdat[,1]
    h1<- ahdat[,2]
    a2<- ahdat[,3]
    h2<- ahdat[,4]
    a3<- ahdat[,5]
    h3<- ahdat[,6]

    dett<-  (a1-a2)*(a3-a2)*(a3-a1)
    alpha<- ((a3-a2)^2)*(h1-h2)-((a1-a2)^2)*(h3-h2)
    beta<-  -(a3-a2)*(h1-h2)+(a1-a2)*(h3-h2)
    alpha<- alpha/dett
    beta<-  beta/dett
    mng<- a2-alpha/(2*beta)
    sdg<- sqrt(-1/(2*beta))
    return(cbind(mng,sdg))
}

gstats.ssnl.f<- function(tagdat,param.g,param.A,param.sig)
{   qt1<- 0.001
    qt2<- 15

    l<- matrix(rep(qt1,nrow(tagdat)),ncol=1)
    u<- matrix(rep(qt2,nrow(tagdat)),ncol=1)

    aa<- gridsch.f(logint.ssnl.f,l,u,tagdat,param.g,param.A,param.sig)
    brk<-0
    for(i in (1:10))
       {ms<- quadmax.f(aa)

	# we need to make sure that the mng values have stabilised
	# if it has we break out
	if(i>3)
	   {stdiff<- abs((ms[,1]-mngold)/ms[,2])
	    msd<- max(stdiff)
	    if(msd<0.2)
	    {   brk<- 1
	        break
	       }
           }

	# if not, we refine the estimates
        a2<- pmax(ms[,1],0.9*aa[,1]+0.1*aa[,5])
        a2<- pmin(a2,0.1*aa[,1]+0.9*aa[,5])
        a1<- pmin(a2,aa[,3])
        a2<- a2+aa[,3]-a1
        a1<- pmin(a1,0.1*aa[,1]+0.9*a2)
        f12<- logint.ssnl.f(cbind(a1,a2),tagdat,param.g,param.A,param.sig)
        tf<- f12[,1]<f12[,2]
        atemp<- cbind(a1,f12[,1],a2,f12[,2],aa[,5:6])
        aa<- cbind(aa[,1:2],atemp[,1:4])
        aa[tf,]<-atemp[tf,]
	mngold<- ms[,1]
       }
    if(brk==0) {assign("nits.gstats",1,where=1)
		print("max # iterations reached")}
    ms<- quadmax.f(aa)
    return(ms)
}

a.l1.l2.ssnl.f<- function(a,tagdat,param.g,param.A,param.sig)
{   # This calculates  a h(l1,l2|a) p(a)

    apa<- a*densA.f(a,param.A)
    integrand<- ha.ssnl.f(a,tagdat,param.g,param.sig)*apa
    return(integrand)
}

ahat.ssnl.f<- function(tagdat,param.g,param.A,param.sig)
{   # this estimates E[A|l1,l2] from the data
    # for given parameter values

    gms<-   gstats.ssnl.f(tagdat,param.g,param.A,param.sig)
    mng<- gms[,1]
    sdg<- gms[,2]
    mean.A<- hermite20.f(a.l1.l2.ssnl.f,tagdat,param.g,param.A,param.sig,
		nrow(tagdat),mng,sdg)
    pdf.l1.l2<- h.ssnl.f(tagdat,param.g,param.A,param.sig)
    mean.A<- mean.A/pdf.l1.l2
    return(mean.A)
}

linfhat.a.ssnl.f<- function(a,tagdat,param.g,param.A,param.sig)
{	# this calculates E[linf|l1,l2,a]

	l1<-	tagdat[,1]
	l2<- 	tagdat[,2]
	t1<-	tagdat[,3]
	t2<- 	tagdat[,4]
	measr<- tagdat[,5]

	mu.L<-		param.g[1]
	sig.L<-	param.g[2]
	param.f<- param.g[3:length(param.g)]

	ucol<- matrix(1,nrow=nrow(a),ncol=1)
  	urow<- matrix(1,nrow=1,ncol=ncol(a))
  	a2<- a+(t2-t1)%*%urow
  	f1<- growth.ssnl.f(a,param.f,t1-floor(t1))
  	f2<- growth.ssnl.f(a2,param.f,t2-floor(t2))
	sig1<- 	error.ssnl.f("release",measr,param.sig)
   	sig2<- 	error.ssnl.f("recapture",measr,param.sig)

	denom<- sig1^2*sig2^2 + sig.L^2*(sig1^2*f2^2 + sig2^2*f1^2)
	numer<- sig2^2*f1*(l1 - mu.L*f1) + sig1^2*f2*(l2 - mu.L*f2)
	linfhat.a<- mu.L + sig.L^2*numer/denom

	return(linfhat.a)
}

linf.int.ssnl.f<- function(a,tagdat,param.g,param.A,param.sig)
{	# this calculates E[linf|l1,l2,a]*h(l1,l2|a)*p(a)

	integrand<- linfhat.a.ssnl.f(a,tagdat,param.g,param.A,param.sig)*
		ha.ssnl.f(a,tagdat,param.g,param.sig)*densA.f(a,param.A)
}

linfhat.ssnl.f<-function(tagdat,param.g,param.A,param.sig)
{ 	# this estimates E[Linf|l1,l2] from the data
  	# for given parameter values

	gms<-   gstats.ssnl.f(tagdat,param.g,param.A,param.sig)
   	mng<- gms[,1]
   	sdg<- gms[,2]
	mean.linf<- hermite20.f(linf.int.ssnl.f,tagdat,param.g,param.A,
		param.sig,nrow(tagdat),mng,sdg)
	pdf.l1.l2<- h.ssnl.f(tagdat,param.g,param.A,param.sig)
	mean.linf<- mean.linf/pdf.l1.l2
   return(mean.linf)
}


#grupo Javier Olazábal - Sebastián Chávarry - Fabrizio figari - Fiorella Valdivia

#funcion normalizar
normalize<-function(val , data , n){
  return((as.numeric(val) - as.numeric(min(data[,n]))) / (as.numeric(max(data[,n]))- as.numeric(min(data[,n]))))
}

#se categoriza data no, sometimes, frequently, always
CategoricData <- function(value) {
  if(value == 'no'){
    return(0)}
  else if(value == 'Sometimes'){
    return(0.3333)
  }else if(value == 'Frequently'){
    return(0.6666)
  }else if(value == 'Always'){
    return(1)
  }else{
    print("error")
    return(-1)
  }
}

#se categoriza data walking,bike, pt, motorbike, automobile
TransData <- function(value) {
  if(value == 'Walking'){
    return(0)}
  else if(value == 'Bike'){
    return(0.25)
  }else if(value == 'Public_Transportation'){
    return(0.5)
  }else if(value == 'Motorbike'){
    return(0.75)
  }else if(value == 'Automobile'){
    return(1)
  }else{
    print("error")
    return(-1)
  }
}

#funcion calcular distancia
calcDist <- function(persona , data){
  #vector donde se va a almacenar la diferencia de la distancia del dataframe con persona
  #y el tipo de peso que le corresponde
  tipo <- c()
  distancia <- c(numeric())

  for (i in 1:nrow(data)){
    dist = 0
    #genero
    if(data[i,1] != persona[1]) dist = dist + 1
    #edad
    dist = dist + (normalize(persona[2], data , 2) - normalize(data[i,2], data, 2))^2
    #altura
    dist = dist + (normalize(persona[3], data , 3) - normalize(data[i,3], data, 3))^2
    #peso
    dist = dist + (normalize(persona[4], data , 4) - normalize(data[i,4], data, 4))^2
    #family history
    if(data[i,5] != persona[5]) dist = dist + 1
    #FAVC
    if(data[i,6] != persona[6]) dist = dist + 1
    #FCVC
    dist = dist + (normalize(persona[7], data , 7) - normalize(data[i,7], data, 7))^2
    #NCP
    dist = dist + (normalize(persona[8], data , 8) - normalize(data[i,8], data, 8))^2
    #caec
    dist = dist + (CategoricData(persona[9]) - CategoricData(data[i,9]))^2
    #smoke
    if(data[i,10] != persona[10]) dist = dist + 1
    #ch20
    dist = dist + (normalize(persona[11], data , 11) - normalize(data[i,11], data, 11))^2
    #SCC
    if(data[i,12] != persona[12]) dist = dist + 1
    #faf
    dist = dist + (normalize(persona[13], data , 13) - normalize(data[i,13], data, 13))^2
    #TUE
    dist = dist + (normalize(persona[14], data , 14) - normalize(data[i,14], data, 14))^2
    #calc
    dist = dist + (CategoricData(persona[15]) - CategoricData(data[i,15]))^2
    #mtrans
    dist = dist + (TransData(persona[16]) - TransData(data[i,16]))^2

    dist = sqrt(dist)
    #almacenao la data para dist y el tipo en vectores
    distancia = c(distancia, as.double(dist))
    tipo = c(tipo,data[i,17])

  }
  distXtipo <- matrix(c(distancia,tipo),nrow = 2111,ncol = 2)
  distXtipo = distXtipo[order(distXtipo[,1]),]
  return(distXtipo)
}

#algoritmo knn
knn <- function(k , distXtipo)
{
  cadena = ""
  index = 1
  max = 0
  flag = FALSE

  #vector (usado como dicc) para asociar los tipos de obesidad mas cercanos
  #ejemplo de dibujo de diccionario
  diccTipos <- c("Normal_Weight" = 0 , "Overweight_Level_I" = 0, "Overweight_Level_II" = 0 , "Obesity_Type_III" = 0,
                 "Obesity_Type_II" = 0 , "Obesity_Type_I" = 0, "Insufficient_Weight" = 0)

  while (k > 0)
  {
    diccTipos[distXtipo[index,2]] <- diccTipos[distXtipo[index,2]] + 1
    index = index + 1
    k = k - 1
    #si ya no quedan m�s vecinos por recorrer
    #cuando el dicc esta completo
    if(k == 0)
    {
      for(i in 1:(length(diccTipos) - 1 ))
      {
        value = diccTipos[i]
        if(max < value){
          cadena = names(value)
          max = value
          flag = FALSE
        }
        else if (max == value){
          flag = TRUE
        }
      }
      #Si la moda se repite en 2 tipos de datos entonces
      #aumentamos en 1 el k
      if (flag == TRUE)
      {
        k = k + 1
      }
    }
  }
  return(cadena)
}

crear_persona <- function()
{

  while (TRUE)
  {
    gender <- as.integer(readline(writeLines("Cual es su genero?\nOPCIONES:\n(0) Masculino\n(1) Femenino ")))
    if (gender == 0) {
      gender <- "Male"
      break
    }
    else if (gender == 1) {
      gender <- "Female"
      break
    }
    else
    {
      print("Ingresar un valor dentro de las opciones")
    }
  }

  age <- as.integer(readline("Cual es su edad?: \n"))

  height <-as.double(readline("Cual es su altura en metros?: \n"))

  weight <-as.double(readline("Cual es su peso en kg?: \n"))

  while (TRUE)
  {
    family_overweight <-as.integer(readline(writeLines("En su familia alguien sufre o ha sufrido de sobrepeso?\nOPCIONES:\n(0) SI\n(1) NO ")))
    if (family_overweight == 0) {
      family_overweight <- "yes"
      break
    }
    else if (family_overweight == 1) {
      family_overweight <- "no"
      break
    }
    else
    {
      print("Ingresar un valor dentro de las opciones")
    }
  }

  while (TRUE)
  {
    favc  <- as.integer(readline(writeLines("Come comida alta en calorias frecuentemente?\nOPCIONES:\n(0) SI\n(1) NO ")))
    if (favc == 0) {
      favc <- "yes"
      break
    }
    else if (favc == 1) {
      favc <- "no"
      break
    }
    else
    {
      print("Ingresar un valor dentro de las opciones")
    }
  }

  while (TRUE)
  {
    fcvc  <-as.integer(readline(writeLines("Come vegetales en su comida?\nOPCIONES:\n(0) Nunca\n(1) A veces\n(2) Siempre? ")))
    if (fcvc == 0)
    {
      fcvc <- 1
      break
    }
    else if (fcvc == 1) {
      fcvc <- 2
      break
    }
    else if (fcvc == 2) {
      fcvc <- 3
      break
    }
    else
    {
      print("Ingresar un valor dentro de las opciones")
    }
  }

  while (TRUE)
  {
    ncp  <-as.integer(readline(writeLines("Cuantas comidas principales ingiere en el dia?\nOPCIONES:\nINgrese un n�mero entre 1-4")))
    if (ncp >= 1 | ncp <=4){
      break
    }
    else
    {
      print("Ingresar un valor dentro de las opciones")
    }
  }

  while (TRUE)
  {
    caec  <- as.integer(readline(writeLines("Come algo durante sus comidas? \nOPCIONES:\n(0) Nunca\n(1) A veces\n(2) Frecuentemente\n(3) Siempre ")))
    if (caec == 0) {
      caec <- "no"
      break
    }
    else if (caec == 1) {
      caec <- "Sometimes"
      break
    }
    else if (caec == 2) {
      caec <- "Frequently"
      break
    }
    else if (caec == 3) {
      caec <- "Always"
      break
    }
    else
    {
      print("Ingresar un valor dentro de las opciones")
    }
  }

  while (TRUE)
  {
    smoke <- as.integer(readline(writeLines("Usted fuma?\n OPCIONES:\n(0) SI\n(1) NO ")))
    if (smoke == 0) {
      smoke <- "yes"
      break
    }
    else if (smoke == 1) {
      smoke <- "no"
      break
    }

    else
    {
      print("Ingresar un valor dentro de las opciones")
    }
  }

  while (TRUE)
  {
    ch20 <-as.integer(readline(writeLines("Cuanta agua bebe al dia?\nOPCIONES:\n(0) Menos de 1 litro\n(1) Entre 1 y 2 litros\n(2) Mas de 2 litros ")))

    if (ch20 == 0)
    {
      ch20 <- 1
      break
    }
    else if (ch20 == 1) {
      ch20 <- 2
      break
    }
    else if (ch20 == 2) {
      ch20 <- 3
      break
    }

    else
    {
      print("Ingresar un valor dentro de las opciones")
    }
  }

  while (TRUE)
  {
    scc <-as.integer(readline(writeLines("Monitorea sus calorias diariamente?\nOPCIONES:\n(0) SI\n(1) NO ")))
    if (scc == 0) {
      scc <- "yes"
      break
    }
    else if (scc == 1) {
      scc <- "no"
      break
    }
    else
    {
      print("Ingresar un valor dentro de las opciones")
    }
  }

  while (TRUE)
  {
    faf <-as.integer(readline(writeLines("Cuantas veces a la semana hace actividad fisica?\nOPCIONES:\n(0) Nunca\n(1) 1 o 2 dias\n(2) 2 o 4 dias\n(3) 4 o 5 dias ")))
    if (faf == 0 | faf == 1 | faf== 2 | faf== 3) {
      break
    }

    else
    {
      print("Ingresar un valor dentro de las opciones")
    }
  }

  while (TRUE)
  {
    tue <-as.integer(readline(writeLines("Cuanto tiempo usa aparatos tecnologicos?\nOPCIONES:\n(0) 0 a 2 horas\n(1) 3 a 5 horas\n(2) Mas de 5 horas ")))
    if (tue == 0 | tue == 1 | tue== 2) {
      break
    }

    else
    {
      print("Ingresar un valor dentro de las opciones")
    }
  }

  while (TRUE)
  {
    calc <-as.integer(readline(writeLines("Que tan amenudo ingiere alcohol?\nOPCIONES:\n(0) Nunca\n(1) A veces\n(2) Frecuentemente\n(3) Siempre ")))
    if (calc == 0) {
      calc <- "no"
      break
    }
    else if (calc == 1) {
      calc <- "Sometimes"
      break
    }
    else if (calc == 2) {
      calc <- "Frequently"
      break
    }
    else if (calc == 3) {
      calc <- "Always"
      break
    }
    else
    {
      print("Ingresar un valor dentro de las opciones")
    }
  }

  while (TRUE)
  {
    mtran <-as.integer(readline(writeLines("Que medio de transporte normalmente usa?\nOPCIONES:\n(0) Automovil\n(1) Motocileta\n(2) Bicicleta\n(3) Transporte publico\n(4) Caminando ")))
    if (mtran == 0) {
      mtran <- "Automobile"
      break
    }
    else if (mtran == 1) {
      mtran <- "Motorbike"
      break
    }
    else if (mtran == 2) {
      mtran <- "Bike"
      break
    }
    else if (mtran == 3) {
      mtran <- "Public_Transportation"
      break
    }
    else if (mtran == 4) {
      mtran <- "Walking"
      break
    }

    else
    {
      print("Ingresar un valor dentro de las opciones")
    }
  }

  persona = c(gender,age,height,weight,family_overweight,favc,fcvc,ncp,caec,smoke,ch20,scc,faf,tue,calc,mtran)

  return(persona)

}

#leemos el csv
data<-read.csv('data.csv')

# persona <- rep(NA, 17) <= para cuando hagamos el input
persona <- crear_persona()
#print(persona)

#persona2 <- c('Female', 15, 1.7 , 80, 'yes' , 'yes' , 2 , 2 , 'Always' , 'no' , 3 , 'yes', 0, 0, 'no','Walking')

paste("La clasificacion de la persona es:", knn(30,calcDist(persona, data)), sept= " ")


# DLC 2019
# set of functions allowing to define Var[y]
# and plot Corr[y] for objects of class
# lmerModLmerTest or lmerMod

Omega.matrix = function(model) {
    if(class(model)[1]=="lmerModLmerTest"|class(model)[1]=="lmerMod"){
        sigma2.epsilon = sigma(model)^2
        Psi.star       = crossprod(getME(model,"Lambdat"))*sigma2.epsilon
        Z              = getME(model,"Z")
        Omega          = Z %*% Psi.star %*% t(Z) + sigma2.epsilon* Diagonal(nrow(Z))
        Omega
    }else{
        warning("Function only works on outcput of function lmer()\n")
    }
    }
    #Corr.fun = function(Sigma){
    #    D = sqrt(diag(diag(Sigma)))
    #    DInv = solve(D)
    #    DInv %*% Sigma %*% DInv
    #    }
Omega.plot = function(Omega,legend=TRUE,axes=TRUE){
    corw = cov2cor(Omega)
    if(any(corw<0)){
        colw=c(gray(1),rainbow(197)[197:100],gray(.9),rainbow(197)[99:1],gray(0))
        zlim=c(-1,1)
    }else{
        colw=c(gray(.9),rainbow(98)[98:1],gray(0))
        zlim=c(0,1)
    }
    image(z=as.matrix(corw[nrow(corw):1,]),zlim=zlim,axes=FALSE,col=colw)
    if(legend){
        valw = as.numeric(names(table(as.matrix(corw))))
        posw = round(valw*length(colw))
        posw[posw==0] = 1
        posw[posw>length(colw)] = length(colw)
        legend("topright",ncol=1,legend=format(round(valw,4)),
               col=colw[posw],pch=15,bg="light gray",
               title="Values",box.lwd=NA)
        }
    if(axes){
        axis(3,at=seq(0,1,length=nrow(Omega)),labels=FALSE)
        axis(2,at=seq(0,1,length=nrow(Omega)),labels=FALSE)
        axis(2,at=c(1,0),c(1,nrow(Omega)),las=2)
        axis(3,at=c(0,1),c(1,nrow(Omega)),las=1)
        }
    }


library(bivpois) # load bivpois library
data(ex2.sim)    # load ex2.sim data from bivpois library
xtemp<-readline(prompt = "Press Enter to Continue")
#
ex2.m1<-lm.bp( x~z1 , y~z1+z5, l1l2=~z3, l3=~.-z5, data=ex2.sim )		# Model  1: BivPois
ex2.m2<-lm.dibp( x~z1 , y~z1+z5, l1l2=~z3, l3=~.-z5, data=ex2.sim , jmax=0)	# Model  2: Zero Inflated BivPois
ex2.m3<-lm.dibp( x~z1 , y~z1+z5, l1l2=~z3, l3=~.-z5, data=ex2.sim , jmax=1)	# Model  3: Diagonal Inflated BivPois with DISCRETE(1) diagonal inflation distribution
ex2.m4<-lm.dibp( x~z1 , y~z1+z5, l1l2=~z3, l3=~.-z5, data=ex2.sim , jmax=2)	# Model  4: Diagonal Inflated BivPois with DISCRETE(2) diagonal inflation distribution
ex2.m5<-lm.dibp( x~z1 , y~z1+z5, l1l2=~z3, l3=~.-z5, data=ex2.sim , jmax=3)	# Model  5: Diagonal Inflated BivPois with DISCRETE(3) diagonal inflation distribution
ex2.m6<-lm.dibp( x~z1 , y~z1+z5, l1l2=~z3, l3=~.-z5, data=ex2.sim , jmax=4)	# Model  6: Diagonal Inflated BivPois with DISCRETE(4) diagonal inflation distribution
ex2.m7<-lm.dibp( x~z1 , y~z1+z5, l1l2=~z3, l3=~.-z5, data=ex2.sim , jmax=5)	# Model  7: Diagonal Inflated BivPois with DISCRETE(5) diagonal inflation distribution
ex2.m8<-lm.dibp( x~z1 , y~z1+z5, l1l2=~z3, l3=~.-z5, data=ex2.sim , jmax=6)	# Model  8: Diagonal Inflated BivPois with DISCRETE(6) diagonal inflation distribution
ex2.m9<-lm.dibp( x~z1 , y~z1+z5, l1l2=~z3, l3=~.-z5, data=ex2.sim , distribution='poisson')	# Model  9: Diagonal Inflated BivPois with POISSON diagonal inflation distribution
ex2.m10<-lm.dibp( x~z1 , y~z1+z5, l1l2=~z3, l3=~.-z5, data=ex2.sim , distribution='geometric')	# Model 10: Diagonal Inflated BivPois with GEOMETRIC diagonal inflation distribution
#
# printing parameters of model 7
ex2.m7$beta1
ex2.m7$beta2
ex2.m7$beta3
ex2.m7$p
ex2.m7$theta
#
# printing parameters of model 9
ex2.m9$beta1
ex2.m9$beta2
ex2.m9$beta3
ex2.m9$p
ex2.m9$theta