library(shiny)
library(rsconnect)
library(ggplot2)

#############################################################
# Set the baseline parameters
#############################################################
base_sI <- .2
base_gL <- .01
base_gA <- .02
base_delta <- .05
base_alpha <- .3
base_A <- 1
base_kalstar <- (base_sI/(base_gL+base_gA+base_delta))^(1/(1-base_alpha))
base_K <- base_kalstar*base_A
base_kystar <- base_sI/(base_gL+base_gA+base_delta)

#############################################################
# Define UI ----
#############################################################
ui <- fluidPage(
  withMathJax(),
  titlePanel("Dynamics of K/AL Ratio"),

  mainPanel(

      #hr(),

      h4("Set parameters"),

      fixedRow(
        column(4,
        sliderInput("alt_sI", h6('New capital share of GDP \\(s_I\\)'),
                    min = 0, max = .5, value = base_sI, ticks = FALSE, step=.01),
        sliderInput("alt_gL", h6("Population growth rate \\(g_L\\)"),
                    min = -.05, max = .05, value = base_gL, ticks = FALSE, step=.01),
        sliderInput("alt_gA", h6("Productivity gorwth rate \\(g_A\\)"),
                    min = -.05, max = .1, value = base_gA, ticks = FALSE, step=.01),
        sliderInput("alt_delta", h6("Depreciation rate \\(\\delta\\)"),
                    min = 0, max = .1, value = base_delta, ticks = FALSE, step=.01),
        sliderInput("alt_alpha", h6("Capital elasticity \\(\\alpha\\)"),
                    min = 0, max = 1, value = base_alpha, ticks = FALSE, step=.01),
        br(),
        actionButton("reset", "Reset all to baseline")
        ),
        column(8,
        plotOutput("gkalgraph",width = "100%"),
        )
      ) # end FluidRow
      ) # end main panel
  ) # end ui
#############################################################
# Define server logic ----
#############################################################
server <- function(input, output, session) {

  # Reset parameters
  observeEvent(input$reset, {
    updateSliderInput(session,'alt_sI',value = base_sI)
    updateSliderInput(session,'alt_gL',value = base_gL)
    updateSliderInput(session,'alt_gA',value = base_gA)
    updateSliderInput(session,'alt_delta',value = base_delta)
    updateSliderInput(session,'alt_alpha',value = base_alpha)
  })

  output$gkalgraph <- renderPlot(
    {
      kalstar = (input$alt_sI/(input$alt_gL + input$alt_gA + input$alt_delta))^(1/(1-input$alt_alpha))
      tick <- seq(0,12,.1) # arbitrary kal values
      df <- data.frame(tick) # create dataframe
      df$gk <- input$alt_sI/(df$tick^(1-input$alt_alpha))- input$alt_delta
      reverse = (input$alt_sI/(input$alt_delta+.12))^(1/(1-input$alt_alpha))

      ggplot(df, aes(x=tick)) +
        geom_line(aes(y = gk),size=1) +
        geom_hline(yintercept=input$alt_gA+input$alt_gL, linetype="dashed", color = "black",size=1) +
        geom_vline(xintercept=kalstar, linetype="dotted", color = "black") +
        annotate(geom="text", x=9, y=input$alt_gA+input$alt_gL+.005,
                 label="gA + gL",size=6) +
        annotate(geom="text", x=kalstar+1.6, y=.12,
                 label="K/AL steady state",size=6) +
        annotate(geom="text", x=reverse-.4, y=.12,
                 label="gK",size=6) +
        xlab("K/AL ratio") +
        ylab("Growth rates") +
        theme_light() +
        ylim(-.01,.12)
    }
  ) # end gky graph

} # end server

# Run the app ----
shinyApp(ui = ui, server = server)


# Group members (Name, Student ID, E-Mail):
# 1. Baldomero Valdez,  Valenzuela, 2905175, baldmer.w@gmail.com
# 2. Omar Trinidad Gutierrez Mendez, 2850441, omar.vpa@gmail.com
# 3. Shinho Kang, 2890169, wis.shinho.kang@gmail.com

# Exercise 4.2

# install `multtest` package
# source("https://bioconductor.org/biocLite.R")
# biocLite("multtest")

setwd("~/current-lectures/ml_bioinformatics/Ex4/")
library(multtest)
data(golub)

# a) calculate the mean and variance of all pooled expression data
meanGolub = apply(golub, 1, mean)
varGolub = apply(golub, 1, var)
sdGolub = apply(golub, 1, sd)

# b) means and standard deviations of the expression level for every gene for
# the classes ALL and AML

# i. create glb.fac
glb.fac = factor(golub.cl, levels=0:1, labels=c("ALL", "AML"))

meanALL = apply(golub[, glb.fac=="ALL"], 1, mean)
sdALL = apply(golub[, glb.fac=="ALL"], 1, sd)
meanAML = apply(golub[, glb.fac=="AML"], 1, mean)
sdAML = apply(golub[, glb.fac=="AML"], 1, sd)

# ii. 5 genes with the largest mean expression for ALL
largestALL = order(meanALL, decreasing = T)
print("5 genes with the largest mean expression for ALL")
print(golub.gnames[largestALL[1:5], 2])

# ii. 5 genes with the largest mean expression for AML
largestAML = order(meanAML, decreasing = T)
print("5 genes with the largest mean expression for AML")
print(golub.gnames[largestAML[1:5], 2])

# selection of the oncogene
oncogenes = grep('oncogene', golub.gnames[ , 2], ignore.case = T)

# iii. 5 oncogenes with the largest mean expression for ALL
meanOncoALL = apply(golub[oncogenes, glb.fac=="ALL"], 1, mean)
largestOncoALL = order(meanOncoALL, decreasing = T)
loncoALL = oncogenes[largestOncoALL[1:5]]
print("5 oncogenes with the largest mean expression for ALL")
print(golub.gnames[loncoALL, 2])

# iii. 5 oncogenes with the largest mean expression for AML
meanOncoAML = apply(golub[oncogenes, glb.fac=="AML"], 1, mean)
largestOncoAML = order(meanOncoAML, decreasing = T)
loncoAML = oncogenes[largestOncoAML[1:5]]
print("5 oncogenes with the largest mean expression for AML")
print(golub.gnames[loncoAML, 2])

# iv. genes with largest different in expression between the two classes
difference <- order(abs(meanAML-meanALL), decreasing=TRUE)

# print this on a file
names = golub.gnames[difference[1:5], 2]
mean = meanGolub[difference[1:5]]
standard_deviation = sdGolub[difference[1:5]]
data_frame = data.frame(names, mean, standard_deviation)
write.csv(data_frame, file = "Ex4_2b_iv.csv")

# 2c. Select gene 1042
geneCCND3 = split(golub[1042, ], glb.fac)

# i. Boxplot for the expression data
png(filename="boxplot.png")
boxplot(golub[1042,] ~ glb.fac,
        main="Boxplot GeneCCND3",
        xlab="Class",
        ylab="Expression",
        col=c("tomato", "green")
        )
dev.off()

# ii. Q-Q plot with theoretical normal distribution

#
png(filename="qq-plot.png")
par(mfrow=c(1, 2))
qqnorm(geneCCND3$ALL)
qqline(geneCCND3$ALL)
qqnorm(geneCCND3$AML)
qqline(geneCCND3$AML)
dev.off()

# iii. We have to apply the unpaired two-sample t-test (page 94).
# we can see that the size and variance of the two groups are different:
# length(geneCCND3$AML) == length(geneCCND3$ALL)
# var(geneCCND3$AML) == var(geneCCND3$ALL)
# so, we can apply the Welch t-test

ttest = t.test(geneCCND3$AML, geneCCND3$ALL)

# iv. Use a non-parametric test. The Kolmogorov-Smirnov test
kolmogorov = ks.test(geneCCND3$AML, geneCCND3$ALL)

# Shapiro-wilk test
a = shapiro.test(geneCCND3$AML)
b = shapiro.test(geneCCND3$ALL)

# 2d. Perform t-test for all genes comparing the distributions for ALL and AML.

# i. comparison of p-value and alpha
# if p-value < 0.05 we find a significant difference

pvalues <- apply(golub, 1, function(x) t.test(x ~ glb.fac)$p.value)
alpha = 0.05
results = table(pvalues < alpha)
total_i = results[names(results) == T]
print("Genes with significant differences are:")
print(total_i)

# ii. Given that we have more hypothesis, we increase the likelihood of a rare
# event, then we increase the likelihood of incorrectly rejecting a null
# hypothesis.

# iii. Using Bonferroni correction we will redefine the alpha value
# alpha = alpha / number of samples

bonferroni = alpha/nrow(golub)
conf_level = 1 - bonferroni

# modify the alpha value with the parameter conf.level in t.test function
pvalues <- apply(golub, 1, function(x) t.test(x ~ glb.fac, conf.level=conf_level)$p.value)
results = table(pvalues < bonferroni)

total_iii = results[names(results) == T]
print("Genes with significant differences are:")
print(total_iii)


library(odin)
library(reshape2)
library(ggplot2)

sir_ode <- odin::odin({
  ## Derivatives
  deriv(S) <- -b*S*I
  deriv(I) <- b*S*I-g*I
  deriv(R) <- g*I

  ## Initial conditions
  initial(S) <- 0.99
  initial(I) <- 0.01
  initial(R) <- 0.00

  ## parameters
  b <- 0.1
  g <- 0.05
  config(base) <- "sir"
}, ".")

sir_mod <- sir_ode()
times <- seq(0,200,length.out=2001)
sir_out <- sir_mod$run(times)

sir_out_long <- melt(as.data.frame(sir_out),"t")

# Plot
ggplot(sir_out_long, aes(x=t, y=value, colour=variable, group=variable)) +
  geom_line(lwd=2) + xlab("Time")+ylab("Number")


#' Evaluate the cumulative distribution function of a density approximation
#'
#' Currently only implemented for Gaussian mixtures.
#' @param fit An mvd.density object obtained from one of the density fitting functions.
#' @param x Matrix or vector of positions at which to evaluate the density function.
#' @param log Boolean which specifies whether to return the cumulative probability in log space.
#' @export
mvd.cdf <- function(fit, x, log = FALSE) {
    stopifnot(class(fit) == "mvd.density")

    if (fit$type == "gmm") {
        if (is.matrix(x)) {
            stopifnot(ncol(x) == ncol(fit$centers))

          p <- matrix(NA, nrow(x), fit$K)
          for (ki in 1:fit$K) {
            if (log) {
              p[, ki] <- mvtnorm::pmvnorm(x, fit$centers[ki,], fit$covariances[[ki]], log = TRUE) + log(fit$proportions[ki])
            } else {
              p[, ki] <- mvtnorm::pmvnorm(x, fit$centers[ki,], fit$covariances[[ki]], log = FALSE) * fit$proportions[ki]
            }
          }

          if (log) {
            return(apply(p, 1, .logsum))
          } else {
            return(apply(p, 1, sum))
          }
        } else {
          stopifnot(length(x) == ncol(fit$centers))

          p <- rep(NA, fit$K)
          for (ki in 1:fit$K) {
            if (log) {
              p[ki] <- mvtnorm::pmvnorm(x, fit$centers[ki,], fit$covariances[[ki]], log = TRUE) + log(fit$proportions[ki])
            } else {
              p[ki] <- mvtnorm::pmvnorm(x, fit$centers[ki,], fit$covariances[[ki]], log = FALSE) * fit$proportions[ki]
            }
          }

          if (log) {
            return(.logsum(p))
          } else {
            return(sum(p))
          }
        }
    } else if (fit$type == "gmm.truncated") {
      if (is.matrix(x)) {
        stopifnot(ncol(x) == ncol(fit$centers))

        p <- matrix(NA, nrow(x), fit$K)
        for (ki in 1:fit$K) {
          if (log) {
            p[, ki] <- tmvtnorm::ptmvnorm(x, fit$centers[ki,], fit$covariances[[ki]], lower = fit$bounds[, 1], upper = fit$bounds[, 2], log = TRUE) + log(fit$proportions[ki])
          } else {
            p[, ki] <- tmvtnorm::ptmvnorm(x, fit$centers[ki,], fit$covariances[[ki]], lower = fit$bounds[, 1], upper = fit$bounds[, 2], log = FALSE) * fit$proportions[ki]
          }
        }

        if (log) {
          return(apply(p, 1, .logsum))
        } else {
          return(apply(p, 1, sum))
        }
      } else {
        stopifnot(length(x) == ncol(fit$centers))

        p <- rep(NA, fit$K)
        for (ki in 1:fit$K) {
          if (log) {
            p[ki] <- tmvtnorm::ptmvnorm(x, fit$centers[ki,], fit$covariances[[ki]], lower = fit$bounds[, 1], upper = fit$bounds[, 2], log = TRUE) + log(fit$proportions[ki])
          } else {
            p[ki] <- tmvtnorm::ptmvnorm(x, fit$centers[ki,], fit$covariances[[ki]], lower = fit$bounds[, 1], upper = fit$bounds[, 2], log = FALSE) * fit$proportions[ki]
          }
        }

        if (log) {
          return(.logsum(p))
        } else {
          return(sum(p))
        }
      }
    } else {
      stop("Unknown type or not implemented")
    }
}


#-- this codes perfomes a PCA + stat on first discriminant
#input : Multi_datainput_m (after get_behav_gp.r)
#ouput : plspca (plot) and PCA_pval (PCA_pval$p.value)

#---------------------1 make the pca on data
input.pca <- prcomp(Multi_datainput_m %>% select (-groupingvar),
                    center = TRUE,
                    scale. = TRUE)

#---------------------2  statistics on pc1:
Moddata = as.data.frame(input.pca$x)
Moddata$groupingvar = as.factor(Multi_datainput_m$groupingvar)

#-- Mann-Whitney test if 2 groups, Kruskal-Wallis rank sum test otherwise
if (length(levels (Moddata$groupingvar)) == 2) {
  PCA_pval = wilcox_test(PC1 ~ groupingvar, data = Moddata)
  PCA_effectsize = wilcox_effsize(data= Moddata, PC1 ~ groupingvar, comparisons = NULL, ref.group = NULL,
                                  paired = FALSE, alternative = "two.sided", mu = 0, ci = FALSE,
                                  conf.level = 0.95, ci.type = "perc", nboot = 1000)

} else {
  PCA_pval = kruskal_test(PC1 ~ groupingvar, data = Moddata)
  PCA_effectsize = kruskal_effsize(Moddata, PC1 ~ groupingvar, ci = FALSE, conf.level = 0.95,
                                            ci.type = "perc", nboot = 1000)
}

#-- effect size calculation

#-- put stat results in a text
PCA_res <- ifelse (
  pvalue(PCA_pval) < .05,
  paste0("p < ", signif(pvalue(PCA_pval), digits = 2), ", effect size is ", PCA_effectsize$magnitude, " (Z/square(N) = ",signif(PCA_effectsize$effsize, digits = 2),
         ")."),
  "no statistically significant difference."
)

#-- plot 2 PC, add stat text in axes legend
plspca = Moddata %>% ggplot (aes (x = PC1, y = PC2, color = groupingvar)) +
  geom_point() +
  labs (title = paste0("PCA results (", groupingby, " variables grouping)")) +
  scale_colour_grey() + theme_bw() +
  labs(x = paste0 ("PC1: ", PCA_res))

#print(plspca)

#-- Plot boxplot of PC1

# calculate sample size
a <-
  aggregate(PC1 ~ groupingvar + groupingvar , Moddata, function(i)
    c(val = length(i), ypos = quantile(i)[2]))

#do boxplot, stat result as text between groups

boxplotPCA1 = Moddata %>% ggplot (aes (x = groupingvar, y = PC1, color = groupingvar)) +
  geom_boxplot(position = position_dodge(width = 0.9)) +
  labs (title = paste0("PCA results (", groupingby, " variables grouping)")) +
  geom_text(x = 1.5,
            y = max(Moddata$PC1) - 1,
            label = PCA_res) +
  geom_text(data = a,
            aes(y = PC1[, 2] + 0.5, label = paste0("n = ", PC1[, 1])),
            position = position_dodge(width = 0.9)) +
  theme_bw() +  theme(legend.position = 'none') +
  labs(x = metadata$group_by[1])


#' Expected path costs
#'
#' This function calculates expected path costs as a function of mean link flows under various probability models. Its primary use is when called by the function GSUE. For the product multinomial model, a normal approximation to higher order moments is applied unless the link path incidencde matrix is diagonal.
#'
#' @param x Vector of mean link flows
#' @param ODdemand Vector of origin-destination (OD) travel demands
#' @param ODpair Vector indicating the OD pair serviced by each route (ordered by columns of the path-link incidence matrix, A).
#' @param A Path-link incidence matrix
#' @param Alpha Vector of free flow travel time parameters for each link
#' @param Beta Vector of capacity parameters for each link
#' @param pow Polynomial order of cost function for each link. Defaults to 4.
#' @param theta A dispersion parameter. For the logit model, a single value specifying the logit parameter. For the probit model, a vector of standard deviations for the individual link cost errors. Defaults to 1.
#' @param prob.model Route choice probability model. One of "ProductMN" (product multinomial, the default), or "Poisson".
#' @return Vector of expected path costs
#' @keywords expected mean path costs
#' @examples
#' ExpectedPathCost()
#' @export

ExpectedPathCost <- function(x,ODdemand,ODpair,A=diag(length(x)),Alpha,Beta,pow=4,prob.model="ProductMN"){
	Beta[pow==0] <- 1
	if(prob.model=="Poisson"){
		Omega <- A%*%diag(x)%*%t(A)
		omega <- diag(Omega)
		nu <- A%*%x
		ec <- (pow==0)*Alpha + (pow==1)*Alpha*(1 + 0.15*nu/Beta) + (pow==2)*Alpha*(1 + 0.15*((nu/Beta)^2 + omega/Beta^2)) + (pow==4)*Alpha*(1 + 0.15*((nu/Beta)^4 + 6*(nu/Beta)^2*omega/Beta^2 + 3*(omega/Beta^2)^2))
		u <- c(t(A)%*%ec)
	}
	if(prob.model=="ProductMN"){
		if(!is_diag(A)){
			N.routes <- ncol(A)
 			N.OD <- length(ODdemand)
			N.routes.per.OD <- unname(table(ODpair))
			ODdemand.rep <- rep(ODdemand,N.routes.per.OD)
			pp <- x/ODdemand.rep
  			indices <- c(0,cumsum(N.routes.per.OD))
  			Vxx <- matrix(0,ncol=N.routes,nrow=N.routes)
  			for (i in 1:N.OD){
    				indx <- (indices[i]+1):(indices[i+1])
    				Vxx[indx,indx] <- ODdemand[i]*(diag(pp[indx])-pp[indx]%*%t(pp[indx]))
  			}
			Omega <- A%*%Vxx%*%t(A)
			omega <- diag(Omega)
			nu <- A%*%x
			ec <- (pow==0)*Alpha + (pow==1)*Alpha*(1 + 0.15*nu/Beta) + (pow==2)*Alpha*(1 + 0.15*((nu/Beta)^2 + omega/Beta^2)) + (pow==4)*Alpha*(1 + 0.15*((nu/Beta)^4 + 6*(nu/Beta)^2*omega/Beta^2 + 3*(omega/Beta^2)^2))
			u <- c(t(A)%*%ec)
		}
		if(is_diag(A)){
			pp <- x/ODdemand
			nu <- x
			omega2 <- x*(1-pp)
			omega3 <- omega2*(1-2*pp)
			omega4 <- omega2*(1+3*(1-2/ODdemand)*omega2)
			nu2 <- nu^2 + omega2
			nu4 <- nu^4 + 6*omega2*nu^2 + 4*omega3*nu + omega4
    			u <- (pow==0)*Alpha + (pow==1)*Alpha*(1 + 0.15*nu/Beta) + (pow==2)*Alpha*(1 + 0.15*nu2/Beta^2) + (pow==4)*Alpha*(1 + 0.15*nu4/Beta^4)
		}
	}
	u
}


########################################################################
#                                                                      #
#   finite-set.rb                                                      #
#                                                                      #
########################################################################
=begin
[((<index|URL:index.html>))]
[((<finite-map|URL:finite-map.html>))]
((<Algebra::Set>))
/
((<Enumerable>))

= Algebra::Set
((*Class of Set*))

This is the class of sets. The conclusion relationship is determined by
((|each|)) and ((<member?>)), that is, ((|s|)) is the subset of ((|t|))
if and only if
  s.all?{|x| t.member?(x)}
is true.

== File Name:
* ((|finite-set.rb|))

== SuperClass:
* ((|Object|))

== Included Module:

* ((|Enumerable|))

== Class Methods:

--- ::[]([obj0, [obj1, [obj2, ...]]])
    Creates ((|Set|)) objects from parameters.

    Example: Create {"a", [1, 2], 0}
      require "finite-set"
      p Algebra::Set[0, "a", [1, 2]]
      p Algebra::Set.new(0, "a", [1, 2])
      p Algebra::Set.new_a([0, "a", [1, 2]])
      p Algebra::Set.new_h({0=>true, "a"=>true, [1, 2]=>true})

--- ::new([obj0, [obj1, [obj2, ...]]])
    Creates ((|Set|)) objects from parameters.

--- ::new_a(a)
    Creates ((|Set|)) objects from an array ((|a|)).

--- ::new_h(h)
    Creates ((|Set|)) objects from a hash.

--- ::empty_set
    Returns the empty set.

--- ::phi
--- ::null
    Alias of ((<::empty_set>)).

--- ::singleton(x)
    Creates the set of one element ((|x|)).

== Methods:

--- empty_set
    Returns the empty set.

--- phi
--- null
    Alias of ((<::empty_set>)).

--- empty?
    Returns true if ((|self|)) is the empty set.

--- phi?
--- empty_set?
--- null?
    Alias of ((<empty?>))

--- singleton(x)
    Creates the set of one element ((|x|)).

--- singleton?
    Returns true if ((|self|)) is a singleton set.

--- size
    Returns the size of ((|self|)).

--- each
    Iterates the block with the block parameter of each element.
    The order of iteration is indefinite.

    Example:
      require "finite-set"
      include Algebra
      Set[0, 1, 2].each do |x|
        p x #=> 1, 0, 2
      end

--- separate
    Returns the set of the elements which make the block true.

    Example:
      require "finite-set"
      include Algebra
      p Set[0, 1, 2, 3].separate{|x| x % 2 == 0} #=> {2, 0}

--- select_s
--- find_all_s
    Alias of ((<separate>))

--- map_s
    Return the set of the values of the block.

    Example:
      require "finite-set"
      include Algebra
      p Set[0, 1, 2, 3].map_s{|x| x % 2 + 1} #=> {2, 1}

--- pick
    Returns a elements of ((|self|)). The chois is indefinite.

--- shift
    Takes an element from ((<self>)) and returns it.

    Example:
      require "finite-set"
      include Algebra
      s = Set[0, 1, 2, 3]
      p s.shift #=> 2
      p s #=> {0, 1, 3}

--- dup
    Returns the duplication of ((|self|)).

--- append!(x)
    Appends ((|x|)) to ((|self|)) and returns ((|self|)).

--- push
--- <<
    Alias of ((|append!|)).

--- append(x)
    Duplicates and appends ((|x|)) to it and returns it.

--- concat(other)
    Adds the all elements of ((|other|)). This is the destructive
    version of ((<+>)).

--- rehash
    Rehashes the internal ((|Hash|)) object.

--- eql?(other)
    Returns true if ((|self|)) is equal to ((|other|)). This is
    equivalent to (({ self >= other and self <= other})).

--- ==
    Alias of eql?

--- hash
    Returns the hash value of ((|self|)).

--- include?(x)
    Returns true if ((|x|)) is a element of ((|self|)).

--- member?
--- has?
--- contains?
    Alias of ((<include>)).

--- superset?(other)n
    Returns true if ((|self|)) containds ((|other|)).
    This is equivalent to (({other.all{|x| member?(x)}})).

--- >=
--- incl?
    Alias of (({superset?})).

--- subset?(other)
    Returns true if ((|self|)) is a subset of ((|other|)).

--- <=
--- part_of?
    Alias of ((<subset?>)).

--- <(other)
    Returns true if ((|self|)) is a proper subset of ((|other|)).

--- >(other)
    Returns true if ((|other|)) is a proper subset of ((|self|)).

--- union(other = nil)
    Returns the union of ((|self|)) and ((|other|)).
    If ((|other|)) is omitted, returns the union of the
    ((|self|)) the set of sets.

    Example:
      require "finite-set"
      include Algebra
      p Set[0, 2, 4].cup Set[1, 3] #=> {0, 1, 2, 3, 4}
      s = Set[*(0...15).to_a]
      s2 = s.separate{|x| x % 2 == 0}
      s3 = s.separate{|x| x % 3 == 0}
      s5 = s.separate{|x| x % 5 == 0}
      p Set[s2, s3, s5].union #=> {1, 7, 11, 13}

--- |
--- +
--- cup
    Alias of ((<union>)).

--- intersection(other = nil)
    Returns the intersection of ((|self|)) and ((|other|)).
    If ((|other|)) is omitted, returns the intersection of the
    ((|self|)) the set of sets.

    Example:
      require "finite-set"
      include Algebra
      p Set[0, 2, 4].cap(Set[4, 2, 0]) #=> {0, 2, 4}
      s = Set[*(0..30).to_a]
      s2 = s.separate{|x| x % 2 == 0}
      s3 = s.separate{|x| x % 3 == 0}
      s5 = s.separate{|x| x % 5 == 0}
      p Set[s2, s3, s5].cap #=> {0, 30}

--- &
--- cap
    Alias of ((<intersection>)).

--- difference(other)
    Returns the set of the elements of ((|self|)) which are not in
    ((|other|)).

--- -
    Alias of ((<difference>)).

--- each_pair
    Iterates with each two different elements of ((|self|)).

    Example:
      require "finite-set"
      include Algebra
      s = Set.phi
      Set[0, 1, 2].each_pair do |x, y|
        s.push [x, y]
      end
      p s == Set[[0, 1], [0, 2], [1, 2]] #=> true

--- each_member(n)
    Iterates with each ((|n|)) different elements of ((|self|)).

    Example:
      require "finite-set"
      include Algebra
      s = Set.phi
      Set[0, 1, 2].each_member(2) do |x, y|
        s.push [x, y]
      end
      p s == Set[[0, 1], [0, 2], [1, 2]] #=> true

--- each_subset
    Iterates over each subset of ((|self|)).

    Example:
      require "finite-set"
      include Algebra
      s = Set.phi
      Set[0, 1, 2].each_subset do |t|
        s.append! t
      end
      p s.size = 2**3 #=> true

--- each_non_trivial_subset
    Iterates over each non trivial subset of ((|self|))

--- power_set
    Returns the set of subsets.

--- each_product(other)
    Iterates over for each ((|x|)) in ((|self|)) and
    each ((|y|)) in ((|other|))

    Exameple:
      require "finite-set"
      include Algebra
      Set[0, 1].each_prodct(Set[0, 1]) do |x, y|
        p [x, y] #=> [0,0], [0,1], [1,0], [1,1]
      end

--- product(other)
    Returns the product set of ((|self|)) and ((|other|)).
    The elements are the arrays of type (({[x, y]})).
    If the block is given, it returns the set which consists
    of the value of the block.

    Example:
      require "finite-set"
      include Algebra
      p Set[0, 1].product(Set[0, 1]) #=> {[0,0], [0,1], [1,0], [1,1]}
      p Set[0, 1].product(Set[0, 1]){|x, y| x + 2*y} #=> {0, 1, 2, 3]

--- *
    Alias of ((<product>)).

--- equiv_class([equiv])
    Returns the quotient set by the equivalent relation.
    The relation are given as following:

    (1) The evaluation of the block:
          require "finite-set"
          include Algebra
          s = Set[0, 1, 2, 3, 4, 5]
          p s.equiv_class{|a, b| (a - b) % 3 == 0} #=> {{0, 3}, {1, 4}, {2, 5}}
    (2) The value of the instance method
        ((|call(x, y)|)) of the parameter.
          require "finite-set"
          include Algebra
          o = Object.new
          def o.call(x, y)
            (x - y) % 3 == 0
          end
          s = Set[0, 1, 2, 3, 4, 5]
          p s.equiv_class(o) #=> {{0, 3}, {1, 4}, {2, 5}}
    (3) The value of method indicated ((|Symbol|)).
          require "finite-set"
          include Algebra
          s = Set[0, 1, 2, 3, 4, 5]
          def q(x, y)
            (x - y) % 3 == 0
          end
          p s.equiv_class(:q) #=> {{0, 3}, {1, 4}, {2, 5}}

--- /
    Alias of ((<equiv_class>)).

--- to_a
    Returns the array of elements. The order is indefinite.

--- to_ary
    Alias of ((<to_a>)).

--- sort
    Returns the value of (({to_a.sort})).

--- power(other)
    Returns the all maps from ((|other|)) to ((|self|)).
    The maps are the instances of ((<Map|URL:finite-map.html>)).

    Example:
      require "finite-map"
      include Algebra
      a = Set[0, 1, 2, 3]
      b = Set[0, 1, 2]
      s =
      p( (a ** b).size )      #=> 4 ** 3 = 64
      p b.surjections(a).size #=> S(3, 4) = 36
      p a.injections(b).size  #=> 4P3 = 24

--- ** power
    Alias of ((<power>)).

--- identity_map
    Returns the identity map of ((|self|)).

--- surjections(other)
    Returns all surjections from ((|other|)) to((|self|)).

--- injections(other)
    Returns all injections from ((|other|)) to((|self|)).

--- bijections(other)
    Returns all bijections from ((|other|)) to((|self|)).

#--- monotonic_series #what is this?
#
#    Example:

= Enumerable

== File Name:
* ((|finite-set.rb|))

== Methods:

--- any?
    Returns true when the block is true for some elements.
    This is the alias of ((|Enumerable#find|))
    (built-in method of ruby-1.8).

--- all?
    Returns true when the block is true for all elements.
    This is defined by:

      !any?{|x| !yield(x)}

    (These are built-in methods of ruby-1.8).

=end


	# DATA SETUP

		charity = read.csv("./charity.csv")
		charity.t = charity
		charity.t$avhv = log(charity.t$avhv)
		charity.t$agif = log(charity.t$agif)
		charity.t$inca = log(charity.t$inca)
		charity.t$incm = log(charity.t$incm)
		charity.t$lgif = log(charity.t$lgif)
		charity.t$rgif = log(charity.t$rgif)
		charity.t$tgif = log(charity.t$tgif)
		charity.t$tlag = log(charity.t$tlag)

		data.train = charity.t[charity$part=="train",]
		x.train = data.train[,2:21]
		c.train = data.train[,22] # donr
		n.train.c = length(c.train) # 3984
		y.train = data.train[c.train==1,23] # damt for observations with donr=1
		# x.train.mat = model.matrix(damt~., data.train[c.train==1,2:23])[,-22]
		n.train.y = length(y.train) # 1995

		data.valid = charity.t[charity$part=="valid",]
		x.valid = data.valid[,2:21]
		c.valid = data.valid[,22] # donr
		n.valid.c = length(c.valid) # 2018
		y.valid = data.valid[c.valid==1,23] # damt for observations with donr=1
		#x.valid.mat = model.matrix(damt~., data.valid[c.valid==1,2:23])[,-22]
		n.valid.y = length(y.valid) # 999

		data.test = charity.t[charity$part=="test",]
		n.test = dim(data.test)[1] # 2007
		x.test = data.test[,2:21]

		x.train.mean = apply(x.train, 2, mean)
		x.train.sd = apply(x.train, 2, sd)
		x.train.std = t((t(x.train)-x.train.mean)/x.train.sd) # standardize to have zero mean and unit sd
		# x.train.mat.mean = apply(x.train.mat, 2, mean)
		# x.train.mat.sd = apply(x.train.mat, 2, sd)
		# x.train.mat.std = t((t(x.train.mat)-x.train.mat.mean)/x.train.mat.sd) # standardize to have zero mean and unit sd
		apply(x.train.std, 2, mean) # check zero mean
		apply(x.train.std, 2, sd) # check unit sd
		data.train.std.c = data.frame(x.train.std, donr=c.train) # to classify donr
		data.train.std.y = data.frame(x.train.std[c.train==1,], damt=y.train) # to predict damt when donr=1

		x.valid.std = t((t(x.valid)-x.train.mean)/x.train.sd) # standardize using training mean and sd
		# x.valid.mat.std = t((t(x.valid.mat)-x.train.mat.mean)/x.train.mat.sd) # standardize to have zero mean and unit sd
		data.valid.std.c = data.frame(x.valid.std, donr=c.valid) # to classify donr
		data.valid.std.y = data.frame(x.valid.std[c.valid==1,], damt=y.valid) # to predict damt when donr=1

		x.test.std = t((t(x.test)-x.train.mean)/x.train.sd) # standardize using training mean and sd
		data.test.std = data.frame(x.test.std)

		train.dat = data.frame(x = x.train.std, y = as.factor(data.train.std.c$donr))
		valid.dat = data.frame(x = x.valid.std, y = as.factor(data.valid.std.c$donr))

	#LIBRARIES

		library(MASS)
		library(tree)
		library(randomForest)
		library(gbm)
		library(e1071)
		library(lars)
		library(leaps)
		library(glmnet)
		library(pls)
		library(splines)
		library(gam)
		library(ISLR)

	#CLASSIFICATION MODELS: LDA, TREES-BASED, AND SVM

		#LDA Model Base
			model.ldaB = lda(y ~ x.reg1 + x.reg2 + x.reg3 + x.reg4 + x.home + x.chld + x.hinc + x.genf + x.wrat +
								x.avhv + x.incm + x.inca + x.plow + x.npro + x.tgif + x.lgif + x.rgif + x.tdon +
								x.tlag + x.agif,
							  train.dat) # include additional terms on the fly using I()

			post.valid.ldaB = predict(model.ldaB, valid.dat)$posterior[,2] # n.valid.c post probs

			profit.ldaB = cumsum(14.5*c.valid[order(post.valid.ldaB, decreasing=T)]-2)
			plot(profit.ldaB) # see how profits change as more mailings are made
			n.mail.valid = which.max(profit.ldaB) # number of mailings that maximizes profits
			c(n.mail.valid, max(profit.ldaB)) # report number of mailings and maximum profit

			cutoff.ldaB = sort(post.valid.ldaB, decreasing=T)[n.mail.valid+1] # set cutoff based on n.mail.valid
			chat.valid.ldaB = ifelse(post.valid.ldaB>cutoff.ldaB, 1, 0) # mail to everyone above the cutoff
			ldaB.table = table(chat.valid.ldaB, c.valid) # classification table
				ldaB.mail = sum(ldaB.table[2,])
				ldaB.mail.tp = ldaB.table[2,2]
				ldaB.error = (ldaB.table[2,1]+ldaB.table[1,2])/2018
				ldaB.profit = 14.5*ldaB.mail.tp - 2*ldaB.mail

				ldaB.error #validation error rate: 0.2235
				ldaB.mail #total mailings: 1,406
				ldaB.profit #total profit: $11,354.50

		#LDA Model Base + Quad (hinc, chld, tdon, tlag, wrat, inca, npro, tgif)
			model.ldaF = lda(y ~ x.reg1 + x.reg2 + x.reg3 + x.reg4 + x.home + x.chld + x.hinc + x.genf + x.wrat +
                     x.avhv + x.incm + x.inca + x.plow + x.npro + x.tgif + x.lgif + x.rgif + x.tdon +
					 x.tlag + x.agif + I(x.hinc^2) + I(x.chld^2) + I(x.tdon^2) + I(x.tlag^2) + I(x.wrat^2) +
					 I(x.inca^2) + I(x.npro^2) + I(x.tgif^2),
                 train.dat) # include additional terms on the fly using I()

			post.valid.ldaF = predict(model.ldaF, valid.dat)$posterior[,2] # n.valid.c post probs

			profit.ldaF = cumsum(14.5*c.valid[order(post.valid.ldaF, decreasing=T)]-2)
			#plot(profit.ldaF) # see how profits change as more mailings are made
			n.mail.valid = which.max(profit.ldaF) # number of mailings that maximizes profits
			c(n.mail.valid, max(profit.ldaF)) # report number of mailings and maximum profit

			cutoff.ldaF = sort(post.valid.ldaF, decreasing=T)[n.mail.valid+1] # set cutoff based on n.mail.valid
			chat.valid.ldaF = ifelse(post.valid.ldaF>cutoff.ldaF, 1, 0) # mail to everyone above the cutoff
			ldaF.table = table(chat.valid.ldaF, c.valid) # classification table
				ldaF.mail = sum(ldaF.table[2,])
				ldaF.mail.tp = ldaF.table[2,2]
				ldaF.error = (ldaF.table[2,1]+ldaF.table[1,2])/2018
				ldaF.profit = 14.5*ldaF.mail.tp - 2*ldaF.mail

				ldaF.error #validation error rate: 0.1660
				ldaF.mail #total mailings: 1,326
				ldaF.profit #total profit: $11,775.50

		#CLASSIFICATION TREE, BASE MODEL

				model.treeB=tree(y~.,train.dat)
				summary(model.treeB)
				model.treeB

				tree.pred=predict(model.treeB,valid.dat,type="class")
				treeB.table = table(tree.pred,valid.dat$y)
				treeB.mail = sum(treeB.table[2,])
				treeB.mail.tp = treeB.table[2,2]
				treeB.error = (treeB.table[2,1]+treeB.table[1,2])/2018
				treeB.profit = 14.5*treeB.mail.tp - 2*treeB.mail

				treeB.error #validation error rate: 0.1516
				treeB.mail #total mailings: 1,165
				treeB.profit #total profit: $11,140.50

		#CLASSIFICATION TREE, RANDOM FORESTS MODEL

			#THE BELOW LOOP TO DISCOVER WHICH SEED RETURNS MAXIMUM PROFIT (SET.SEED(53) RETURNED MAXIMUM)
			# mat = matrix(, ncol=4)

			# for(i in 1:100){
				# iter = i
				# set.seed(i)
				# model.rf = randomForest(y~., train.dat, mtry = 4, importance = TRUE)

				# summary(model.rf)
				# model.rf

				# tree.pred=predict(model.rf, valid.dat, type = "class")
				# rf.table = table(tree.pred, valid.dat$y)
				# rf.mail = sum(rf.table[2,])
				# rf.mail.tp = rf.table[2,2]
				# rf.error = (rf.table[2,1]+rf.table[1,2])/2018
				# rf.profit = 14.5*rf.mail.tp - 2*rf.mail

				# vec = c(iter, rf.error, rf.mail, rf.profit)
				# mat = rbind(mat, vec)
				# # print(i)
				# # print(rf.error) #validation error rate:
				# # print(rf.mail) #total mailings:
				# # print(rf.profit) #total profit: $
			# }

			set.seed(53)
			model.rf = randomForest(y~., train.dat, mtry = 4, importance = TRUE)

			summary(model.rf)
			model.rf

			tree.pred=predict(model.rf,valid.dat,type="class")
			rf.table = table(tree.pred,valid.dat$y)
			rf.mail = sum(rf.table[2,])
			rf.mail.tp = rf.table[2,2]
			rf.error = (rf.table[2,1]+rf.table[1,2])/2018
			rf.profit = 14.5*rf.mail.tp - 2*rf.mail

			rf.error #validation error rate: 0.1070
			rf.mail #total mailings: 1,063
			rf.profit #total profit: $11,257.50

		#SVM CLASSIFICATION MODEL

			svm.train = svm(y~ x.reg1 + x.reg2 + x.reg3 + x.reg4 + x.home + x.chld + x.hinc + x.genf + x.wrat +
                     x.avhv + x.incm + x.inca + x.plow + x.npro + x.tgif + x.lgif + x.rgif + x.tdon +
					 x.tlag + x.agif + I(x.hinc^2) + I(x.chld^2) + I(x.tdon^2) + I(x.tlag^2) + I(x.wrat^2) +
					 I(x.inca^2) + I(x.npro^2) + I(x.tgif^2),
					 data = train.dat, kernel = "linear", cost=10,scale = FALSE)

			summary(svm.train)
			set.seed(53)
			tune.charity = tune(svm, y~ x.reg1 + x.reg2 + x.reg3 + x.reg4 + x.home + x.chld + x.hinc + x.genf + x.wrat +
                     x.avhv + x.incm + x.inca + x.plow + x.npro + x.tgif + x.lgif + x.rgif + x.tdon +
					 x.tlag + x.agif + I(x.hinc^2) + I(x.chld^2) + I(x.tdon^2) + I(x.tlag^2) + I(x.wrat^2) +
					 I(x.inca^2) + I(x.npro^2) + I(x.tgif^2),
					 data = train.dat, kernel = "linear", ranges = list(cost = c(0.001, 0.005, 0.01, 0.05, 0.1, 1, 5, 10)))

			summary(tune.charity)
			bestmod = tune.charity$best.model
			summary(bestmod)

			svm.pred = predict(bestmod, valid.dat)
			svm.table = table(predict = svm.pred, truth = valid.dat$y)
			svm.mail = sum(svm.table[2,])
			svm.mail.tp = svm.table[2,2]
			svm.error = (svm.table[2,1]+svm.table[1,2])/2018
			svm.profit = 14.5*svm.mail.tp - 2*svm.mail

			svm.error #validation error rate: 0.1085
			svm.mail #total mailings: 1,054
			svm.profit #total profit: $11,188.50

# PREDICTION MODELING

		# LEAST SQUARES REGRESSION

		#LEAST SQUARE MODEL 1 (LM1): BASE MODEL

			model.ls1 = lm(damt ~ reg1 + reg2 + reg3 + reg4 + home + chld + hinc + genf + wrat +
							  avhv + incm + inca + plow + npro + tgif + lgif + rgif + tdon + tlag + agif,
							data.train.std.y)

			pred.valid.ls1 = predict(model.ls1, newdata = data.valid.std.y) # validation predictions
			mean((y.valid - pred.valid.ls1)^2) # mean prediction error
			# 1.867523
			sd((y.valid - pred.valid.ls1)^2)/sqrt(n.valid.y) # std error
			# 0.1696615

		#LEAST SQUARES MODEL 2 (LM2)

			# drop wrat for illustrative purposes
			model.ls2 = lm(damt ~ reg1 + reg2 + reg3 + reg4 + home + chld + hinc + genf +
							  avhv + incm + inca + plow + npro + tgif + lgif + rgif + tdon + tlag + agif,
							data.train.std.y)

			pred.valid.ls2 = predict(model.ls2, newdata = data.valid.std.y) # validation predictions
			mean((y.valid - pred.valid.ls2)^2) # mean prediction error
			# 1.867433
			sd((y.valid - pred.valid.ls2)^2)/sqrt(n.valid.y) # std error
			# 0.1696498

			# Results

			# MPE  Model
			# 1.867523 LS1
			# 1.867433 LS2

			# select model.ls2 since it has minimum mean prediction error in the validation sample

			yhat.test = predict(model.ls2, newdata = data.test.std) # test predictions

		#LEAST SQUARES MODEL 3 (LM3)

			model.ls3 = lm(damt ~ reg1 + reg2 + reg3 + reg4 + home + chld + hinc + genf + incm +
						plow + tgif + lgif + rgif + tdon + agif,
						data.train.std.y)

			pred.valid.ls3 = predict(model.ls3, newdata = data.valid.std.y) # validation predictions
			ls3.mse = mean((y.valid - pred.valid.ls3)^2) # mean prediction error
			ls3.se = sd((y.valid - pred.valid.ls3)^2)/sqrt(n.valid.y) # std error

			ls3.mse
			ls3.se

		#BEST SUBSETS (BSS)

			bss.train.fit = regsubsets(damt ~ . + I(hinc^2) + I(chld^2) + I(tdon^2) + I(tlag^2) +
					I(wrat^2) + I(inca^2) + I(npro^2) + I(tgif^2) + I(plow^2) + I(agif^2) +
					I(avhv^2) + I(lgif^2) + I(rgif^2) + I(incm^2),
				data=data.train.std.y, nvmax=28)

			which.min(summary(bss.train.fit)$bic)
			coef(bss.train.fit,which.min(summary(bss.train.fit)$bic))
			predict.regsubsets = function(object, newdata, id, ...){
				form = as.formula(object$call[[2]])
				mat = model.matrix(form, newdata)
				coefi = coef(object, id = id)
				xvars = names(coefi)
				mat[, xvars]%*%coefi
			}
			bss.pred = predict.regsubsets(bss.train.fit, data.valid.std.y, which.min(summary(bss.train.fit)$bic))
			bss.mse = mean((y.valid - bss.pred)^2) # mean prediction error
			bss.se = sd((y.valid - bss.pred)^2)/sqrt(n.valid.y) # std error

			bss.mse
			bss.se

		#BEST SUBSETS 10-FOLD VALIDATION (BSSF)

			k=10
			set.seed(53)
			bssf.folds = sample(1:k,nrow(data.train.std.y),replace=TRUE)
			bssf.cv.errors = matrix(NA, k, 10, dimnames=list(NULL, paste(1:10)))
			for (j in 1:k){
				bssf.train.fit=regsubsets(damt ~ . + I(hinc^2) + I(chld^2) + I(tdon^2) + I(tlag^2) +
					I(wrat^2) + I(inca^2) + I(npro^2) + I(tgif^2) + I(plow^2) + I(agif^2) +
					I(avhv^2) + I(lgif^2) + I(rgif^2) + I(incm^2),
					data=data.train.std.y[bssf.folds!=j,], nvmax=28)
				for (i in 1:10){
					bssf.pred = predict(bssf.train.fit, data.train.std.y[bssf.folds==j,], id=i)
					bssf.cv.errors[j, i] = mean((bssf.pred - data.train.std.y$damt[bssf.folds==j])^2)
				}
			}
			bssf.mcv.errors = apply(bssf.cv.errors, 2, mean)
			which.min(bssf.mcv.errors) #Returns the number of variables in the Cross-Validation Selected model
			coef(bssf.train.fit, which.min(bssf.mcv.errors)) #Returns the coefficients for the CV selected model
			bssf.pred = predict.regsubsets(bssf.train.fit, data.valid.std.y, which.min(bssf.mcv.errors)) #Predicts y using the CV Selected model
			bssf.mse = mean((y.valid - bssf.pred)^2) #Calculates test MSE for the CV Selected model
			bssf.se = sd((y.valid - bssf.pred)^2)/sqrt(n.valid.y) # std error

			bssf.mse
			bssf.se

		#RIDGE REGRESSION (RR)

			#make x matrix and y from data.train.std.y
			rr.train.x = model.matrix(damt ~ ., data.train.std.y)[,-21]
			rr.train.y = data.train.std.y$damt
			rr.valid.x = model.matrix(damt ~ ., data.valid.std.y)[,-21]
			rr.valid.y = data.valid.std.y$damt

			set.seed(53)
			rr.cv.out = cv.glmnet(rr.train.x, rr.train.y, alpha=0)

			rr.bestlam = rr.cv.out$lambda.min
			rr.bestlam

			rr.train.fit = glmnet(rr.train.x, rr.train.y, alpha=0, lambda=rr.bestlam)
			coef(rr.train.fit)[, 1]

			rr.pred = predict(rr.train.fit, s=rr.bestlam, newx=rr.valid.x)
			rr.mse = mean((y.valid - rr.pred)^2) # mean prediction error
			rr.se = sd((y.valid - rr.pred)^2)/sqrt(n.valid.y) # std error

			rr.mse
			rr.se

		#LASSO

			set.seed(53)
			lasso.cv.out = cv.glmnet(rr.train.x, rr.train.y, alpha=1)

			lasso.bestlam = lasso.cv.out$lambda.min
			lasso.bestlam

			lasso.train.fit = glmnet(rr.train.x, rr.train.y, alpha=1, lambda=lasso.bestlam)
			coef(lasso.train.fit)[, 1]

			lasso.pred = predict(lasso.train.fit, s=lasso.bestlam, newx=rr.valid.x)
			lasso.mse = mean((y.valid - lasso.pred)^2)
			lasso.se = sd((y.valid - lasso.pred)^2)/sqrt(n.valid.y) # std error

			lasso.mse
			lasso.se

		#PRINCIPAL COMPONANTS

			set.seed(53)
			pcr.train.fit = pcr(damt ~ . + I(hinc^2) + I(chld^2) + I(tdon^2) + I(tlag^2) +
					I(wrat^2) + I(inca^2) + I(npro^2) + I(tgif^2) + I(plow^2) + I(agif^2) +
					I(avhv^2) + I(lgif^2) + I(rgif^2) + I(incm^2),
				data=data.train.std.y, scale=TRUE, validation="CV")

			validationplot(pcr.train.fit,val.type="MSEP")

			#PCR (M=16)
			pcr.pred = predict(pcr.train.fit, data.valid.std.y, ncomp=16)
			pcr.mse = mean((y.valid - pcr.pred)^2) # mean prediction error
			pcr.se = sd((y.valid - pcr.pred)^2)/sqrt(n.valid.y) # std error

			pcr.mse
			pcr.se

			#PCR (M=25)
			pcr.pred = predict(pcr.train.fit, data.valid.std.y, ncomp=25)
			pcr.mse = mean((y.valid - pcr.pred)^2) # mean prediction error
			pcr.se = sd((y.valid - pcr.pred)^2)/sqrt(n.valid.y) # std error

			pcr.mse
			pcr.se

			#PCR (M=34) All
			pcr.pred = predict(pcr.train.fit, data.valid.std.y, ncomp=34)
			pcr.mse = mean((y.valid - pcr.pred)^2) # mean prediction error
			pcr.se = sd((y.valid - pcr.pred)^2)/sqrt(n.valid.y) # std error

			pcr.mse
			pcr.se

		#PARTIAL LEAST SQUARES

			set.seed(53)
			pls.train.fit = plsr(damt ~ . + I(hinc^2) + I(chld^2) + I(tdon^2) + I(tlag^2) +
					I(wrat^2) + I(inca^2) + I(npro^2) + I(tgif^2) + I(plow^2) + I(agif^2) +
					I(avhv^2) + I(lgif^2) + I(rgif^2) + I(incm^2),
				data=data.train.std.y, scale=TRUE, validation="CV")

			validationplot(pls.train.fit,val.type="MSEP")

			#PLS (M=3)
			pls.pred = predict(pls.train.fit, data.valid.std.y, ncomp=3)
			pls.mse = mean((y.valid - pls.pred)^2) # mean prediction error
			pls.se = sd((y.valid - pls.pred)^2)/sqrt(n.valid.y) # std error

			pls.mse
			pls.se

			#PLS (M=6)
			pls.pred = predict(pls.train.fit, data.valid.std.y, ncomp=6)
			pls.mse = mean((y.valid - pls.pred)^2) # mean prediction error
			pls.se = sd((y.valid - pls.pred)^2)/sqrt(n.valid.y) # std error

			pls.mse
			pls.se

			#PLS (M=7)
			pls.pred = predict(pls.train.fit, data.valid.std.y, ncomp=7)
			pls.mse = mean((y.valid - pls.pred)^2) # mean prediction error
			pls.se = sd((y.valid - pls.pred)^2)/sqrt(n.valid.y) # std error

			pls.mse
			pls.se

		#GAM

			#GAM 1
			gam.train.fit1 = gam(damt ~ reg1 + reg2 + reg3 + reg4 + poly(chld, 2) + poly(hinc, 3) +
					poly(wrat, 4) + s(avhv, 3) + s(incm, 3) + s(inca, 3) + s(plow, 3) + s(npro, 3) +
					s(tgif, 3) + s(lgif, 4) + s(rgif, 4) + s(tdon, 3) + s(tlag, 3) + s(agif, 4),
				data=data.train.std.y)

			gam.pred = predict(gam.train.fit1, data.valid.std.y)
			gam.mse = mean((y.valid - gam.pred)^2) # mean prediction error
			gam.se = sd((y.valid - gam.pred)^2)/sqrt(n.valid.y) # std error

			gam.mse
			gam.se

			#GAM 2
			gam.train.fit2 = gam(damt ~ reg1 + reg2 + reg3 + reg4 + poly(chld, 2) + poly(hinc, 3) +
					poly(wrat, 4) + s(avhv, 2) + s(incm, 2) + s(inca, 2) + s(plow, 2) + s(npro, 2) +
					s(tgif, 2) + s(lgif, 3) + s(rgif, 3) + s(tdon, 2) + s(tlag, 2) + s(agif, 3),
				data=data.train.std.y)

			gam.pred = predict(gam.train.fit2, data.valid.std.y)
			gam.mse = mean((y.valid - gam.pred)^2) # mean prediction error
			gam.se = sd((y.valid - gam.pred)^2)/sqrt(n.valid.y) # std error

			gam.mse
			gam.se

	#MODEL LDAF FINAL CLASSIFICATION MODEL

		model.ldaF = lda(donr ~ reg1 + reg2 + reg3 + reg4 + home + chld + hinc + genf + wrat +
						 avhv + incm + inca + plow + npro + tgif + lgif + rgif + tdon +
						 tlag + agif + I(hinc^2) + I(chld^2) + I(tdon^2) + I(tlag^2) + I(wrat^2) +
						 I(inca^2) + I(npro^2) + I(tgif^2),
					 data.train.std.c) # include additional terms on the fly using I()

		n.mail.valid = which.max(profit.ldaF)
		tr.rate = .1 # typical response rate is .1
		vr.rate = .5 # whereas validation response rate is .5
		adj.test.1 = (n.mail.valid/n.valid.c)/(vr.rate/tr.rate) # adjustment for mail yes
		adj.test.0 = ((n.valid.c - n.mail.valid)/n.valid.c)/((1 - vr.rate)/(1 - tr.rate)) # adjustment for mail no
		adj.test = adj.test.1/(adj.test.1+adj.test.0) # scale into a proportion
		n.mail.test = round(n.test*adj.test, 0) # calculate number of mailings for test set
		post.test = predict(model.ldaF, data.test.std)$posterior[,2] # post probs for test data

		cutoff.test = sort(post.test, decreasing=T)[n.mail.test+1] # set cutoff based on n.mail.test
		chat.test = ifelse(post.test>cutoff.test, 1, 0) # mail to everyone above the cutoff
		table(chat.test)

	#GAM1 FINAL PREDICTION MODEL
		yhat.test = predict(gam.train.fit1, newdata = data.test.std) # test predictions

	#OUTPUT
	ip = data.frame(chat=chat.test, yhat=yhat.test) # data frame with two variables: chat and yhat
	write.csv(ip, file="./ip.csv",
          row.names=FALSE) # use group member initials for file name

Data Prep Classification and Prediction Analyis v1.r


library(tidyverse)
library(moments)
library(xtable)
library(gamlss)
options("scipen"=999, "digits"=3)
# установить рабочую директорию
setwd("/home/user/.../Hist/")
# прочитать данные, первая строка --- заголовок, разделитель колонок --- запятая, десятичный разделитель --- точка
# x --- positional аргумент
# header, sep, dec --- named
almatyFlats <- read.csv('', header = TRUE, sep = ",", dec = ".")

spbaFlats <- read.csv('https://github.com/Kirill-Murashev/datasets/blob/main/Saint-Petersburg/flats/spba_flats_210928.csv', header = TRUE, sep = ",", dec = ".")

# изменить тип объекта на более удобный и современный
as_tibble(almatyFlats)

# создать функцию для "нулевой" версии формулы Стёрджесса
kHistSturgess0 <- function(x, na.omit = FALSE){ # создать функцию, игнорировать пропущенные значения
  n   <- NROW(x)                                # вычислить число n
  ks0 = (max(x)-min(x))/(1+log2(n))             # рассчитать k
  return(c(ks0))                                # возвратить k
}                                               # конец функции

# создать функцию для первой версии формулы Стёрджесса
kHistSturgess1 <- function(x, na.omit = FALSE){ # создать функцию, игнорировать пропущенные значения
  n   <- NROW(x)                                # вычислить число n
  ks1 = (1+log2(n))                             # рассчитать k
  return(ks1)                                   # возвратить k
}                                               # конец функции

# создать функцию для второй версии формулы Стёрджесса
kHistSturgess2 <- function(x, na.omit = FALSE){ # создать функцию, игнорировать пропущенные значения
  n   <- NROW(x)                                # вычислить число n
  ks2 = (1+(3.3*log10(n)))                      # рассчитать k
  return(ks2)                                   # возвратить k
}                                               # конец функции

# создать функцию для формулы Брукса и Каррузера
kHistBruksKarruzer <- function(x, na.omit = FALSE){ # создать функцию, игнорировать пропущенные значения
  n   <- NROW(x)                                    # вычислить число n
  kbk = 5*log10(n)                                  # рассчитать k
  return(kbk)                                       # возвратить k
}                                                   # конец функции

# создать функцию для формулы Хайнхольда и Гаеде
kHistHeinholdGaede <- function(x, na.omit = FALSE){ # создать функцию, игнорировать пропущенные значения
  n   <- NROW(x)                                    # вычислить число n
  khg = sqrt(n)                                     # рассчитать k
  return(khg)                                       # возвратить k
}                                                   # конец функции

# создать функцию для формулы Манна и Вальда
kHistMannWald <- function(x, na.omit = FALSE){ # создать функцию, игнорировать пропущенные значения
  n   <- NROW(x)                               # вычислить число n
  kmw = (4*(2^(1/5)))*((n/qnorm(0.95))^0.4)    # рассчитать k
  return(kmw)                                  # возвратить k
}                                              # конец функции

# создать функцию для формулы Уильямса
kHistWilliams <- function(x, na.omit = FALSE){ # создать функцию, игнорировать пропущенные значения
  n   <- NROW(x)                               # вычислить число n
  kwi = (2*(2^(1/5)))*((n/qnorm(0.95))^0.4)    # рассчитать k
  return(kwi)                                  # возвратить k
}                                              # конец функции

# создать функцию для первой формулы Хана и Шапиро
kHistHahnShapiro <- function(x, na.omit = FALSE){ # создать функцию, игнорировать пропущенные значения
  n   <- NROW(x)                                  # вычислить число n
  khs = 4*(0.75*((n-1)^2)^0.2)                    # рассчитать k
  return(khs)                                     # возвратить k
}                                                 # конец функции

# создать функцию для второй формулы Хана и Шапиро
kHistShapiroHahn <- function(x, na.omit = FALSE){ # создать функцию, игнорировать пропущенные значения
  n   <- NROW(x)                                  # вычислить число n
  ksh = 1.9*(n^0.4)                               # рассчитать k
  return(ksh)                                     # возвратить k
}                                                 # конец функции

# создать функцию для формулы Кендалла и Стюарта
kHistKendallStuart <- function(x, na.omit = FALSE){ # создать функцию, игнорировать пропущенные значения
  n   <- NROW(x)                                    # вычислить число n
  b = 2                                             # задать b: 2 <= b <= 4
  t1 = qnorm(0.95)                                  # задать t1
  t2 = 0                                            # задать t2
  kks = b*(sqrt(2)*(((n-1)/(t1+t2))^0.4))           # рассчитать k
  return(kks)                                       # возвратить k
}                                                   # конец функции

# создать функцию для формулы Таушанова
kHistTaushanow <- function(x, na.omit = FALSE){ # создать функцию, игнорировать пропущенные значения
  n   <- NROW(x)                                # вычислить число n
  kta = 4*log10(n)                              # рассчитать k
  return(kta)                                   # возвратить k
}                                               # конец функции

# создать функцию для формулы Тоневой
kHistTonewa <- function(x, na.omit = FALSE){ # создать функцию, игнорировать пропущенные значения
  n   <- NROW(x)                             # вычислить число n
  kto = 5*log10(n)-5                         # рассчитать k
  return(kto)                                # возвратить k
}                                            # конец функции

# создать функцию для формулы Алексеевой
kHistAlekseewa <- function(x, na.omit = FALSE){ # создать функцию, игнорировать пропущенные значения
  n   <- NROW(x)                                # вычислить число n
  kurt = kurtosis(x)                            # вычислить коэффициент эксцесса
  counterkurt = 1/(sqrt(kurt))                  # вычислить коэффициент контрэксцесса
  kal = (4/counterkurt)*(log10(n/10))           # рассчитать k
  return(kal)                                   # возвратить k
}                                               # конец функции

# создать функцию для первой формулы Новицкого
kHistNowiczkij1 <- function(x, na.omit = FALSE){ # создать функцию, игнорировать пропущенные значения
  n   <- NROW(x)                                 # вычислить число n
  kurt = kurtosis(x)                             # вычислить коэффициент эксцесса
  kn1 = ((kurt+1.5)/6)*(n^0.4)                   # рассчитать k
  return(kn1)                                    # возвратить k
}                                                # конец функции

# создать функцию для второй формулы Новицкого
kHistNowiczkij2 <- function(x, na.omit = FALSE){ # создать функцию, игнорировать пропущенные значения
  n   <- NROW(x)                                 # вычислить число n
  kurt = kurtosis(x)                             # вычислить коэффициент эксцесса
  kn2 = (((kurt^4)*(n^2))^(1/5))*(1/3)           # рассчитать k
  return(kn2)                                    # возвратить k
}                                                # конец функции

# создать функцию для третьей формулы Новицкого
kHistNowiczkij3_min <- function(x, na.omit = FALSE){ # создать функцию, игнорировать пропущенные значения
  n   <- NROW(x)                                     # вычислить число n
  kurt = kurtosis(x)                                 # вычислить коэффициент эксцесса
  kn3min = 0.55*(n^0.4)                              # рассчитать k min
  return(kn3min)                                     # возвратить k min
}                                                    # конец функции

# создать функцию для третьей формулы Новицкого
kHistNowiczkij3_max <- function(x, na.omit = FALSE){ # создать функцию, игнорировать пропущенные значения
  n   <- NROW(x)                                     # вычислить число n
  kurt = kurtosis(x)                                 # вычислить коэффициент эксцесса
  kn3max = 1.25*(n^0.4)                              # рассчитать k max
  return(kn3max)                                     # возвратить k max
}                                                    # конец функции

optimalK <- function(x, na.omit = FALSE){ # создать функцию для обобщения результата
  ks0 <- kHistSturgess0(x)
  ks1 <- kHistSturgess1(x)
  ks2 <- kHistSturgess2(x)
  kbk <- kHistBruksKarruzer(x)
  khg <- kHistHeinholdGaede(x)
  kmw <- kHistMannWald(x)
  kwi <- kHistWilliams(x)
  khs <- kHistHahnShapiro(x)
  ksh <- kHistShapiroHahn(x)
  kks <- kHistKendallStuart(x)
  kta <- kHistTaushanow(x)
  kto <- kHistTonewa(x)
  kal <- kHistAlekseewa(x)
  kn1 <- kHistNowiczkij1(x)
  kn2 <- kHistNowiczkij2(x)
  kn3_min <- kHistNowiczkij3_min(x)
  kn3_max <- kHistNowiczkij3_max(x)
  optimal_k <- return(c(ks0, ks1, ks2, kbk, khg, kmw, kwi, khs, ksh, kks, kta, kto, kal, kn1, kn2, kn3_min, kn3_max))
  return(k)
}

kOptimalAlmaty <- optimalK(almatyFlats$price.m)
function_name<- c("Sturgess0", "Sturgess1", "Sturgess2", "BruksKarruzer", "HeinholdGaede", "MannWald", "Williams", "HahnShapiro", "ShapiroHahn", "KendallStuart", "Taushanow", "Tonewa", "Alekseewa", "Nowiczkij1", "Nowiczkij2", "Nowiczkij3_min", "Nowiczkij3_max")
kOptimalAlmaty <- tibble(function_name, kOptimalAlmaty)

xtable(kOptimalAlmaty,caption = "оптимальное число k, полученное различными методами", auto = TRUE)

hist(almatyFlats$price.m,
     freq = FALSE,
     xlab = "price, kaz rubles",
     ylab = "probability",
     main = "Price per meter histogram, Almaty, summer 2019")

histDist(almatyFlats$price.m,
         nbins = kHistNowiczkij1(almatyFlats$price.m),
         xlab = "price, kaz rubles",
         ylab = "probability",
         main = "Price per meter histogram, Almaty, summer 2019")
lines(density(almatyFlats$price.m))
pretty(almatyFlats$price.m)
?histDist

kOptimalSpba <- optimalK(spbaFlats$price_m)
function_name<- c("Sturgess0", "Sturgess1", "Sturgess2", "BruksKarruzer", "HeinholdGaede", "MannWald", "Williams", "HahnShapiro", "ShapiroHahn", "KendallStuart", "Taushanow", "Tonewa", "Alekseewa", "Nowiczkij1", "Nowiczkij2", "Nowiczkij3_min", "Nowiczkij3_max")

kOptimalSpba <- tibble(function_name, kOptimalSpba)

xtable(kOptimalSpba,caption = "оптимальное число k, полученное различными методами", auto = TRUE)

histDist(spbaFlats$price_m,
         nbins = kHistAlekseewa(spbaFlats$price_m),
         xlab = "price, rub",
         ylab = "probability",
         main = "Price per meter, histogram, SPBA (2021-09-28)")
lines(density(spbaFlats$price_m))

rm(kOptimalAlmaty)
rm(kOptimalSpba)
rm(spbaFlats)


=begin
  # sample-factorize02.rb

  require "algebra"

  Z7 = ResidueClassRing(Integer, 7)
  P = Polynomial(Z7, "x")
  x = P.var
  f = 8*x**7 - 20*x**6 + 6*x**5 - 11*x**4 + 44*x**3 - 9*x**2 - 27
  p f.factorize #=> (x + 5)^2(x + 3)^2(x + 2)^3

((<_|CONTENTS>))
=end


model_melting <- function (jul = 0,
         Tmf = 0.5,
         DKmax = 0.0,
         Kmin = 0.0,
         tavg = 0.0){
    #'- Name: Melting -Version: 1.0, -Time step: 1
    #'- Description:
    #'            * Title: snow in the process of melting
    #'            * Author: STICS
    #'            * Reference: doi:http://dx.doi.org/10.1016/j.agrformet.2014.05.002
    #'            * Institution: INRA
    #'            * Abstract: It simulates snow in the process of melting
    #'- inputs:
    #'            * name: jul
    #'                          ** description : current day of year for the calculation
    #'                          ** inputtype : variable
    #'                          ** variablecategory : auxiliary
    #'                          ** datatype : INT
    #'                          ** default : 0
    #'                          ** min : 0
    #'                          ** max : 366
    #'                          ** unit : d
    #'                          ** uri :
    #'            * name: Tmf
    #'                          ** description : threshold temperature for snow melting
    #'                          ** inputtype : parameter
    #'                          ** parametercategory : constant
    #'                          ** datatype : DOUBLE
    #'                          ** default : 0.5
    #'                          ** min : 0.0
    #'                          ** max : 1.0
    #'                          ** unit : degC
    #'                          ** uri :
    #'            * name: DKmax
    #'                          ** description : difference between the maximum and the minimum melting rates
    #'                          ** inputtype : parameter
    #'                          ** parametercategory : constant
    #'                          ** datatype : DOUBLE
    #'                          ** default : 0.0
    #'                          ** min : 0.0
    #'                          ** max : 5000.0
    #'                          ** unit : mmW/degC/d
    #'                          ** uri :
    #'            * name: Kmin
    #'                          ** description : minimum melting rate on 21 December
    #'                          ** inputtype : parameter
    #'                          ** parametercategory : constant
    #'                          ** datatype : DOUBLE
    #'                          ** default : 0.0
    #'                          ** min : 0.0
    #'                          ** max : 5000.0
    #'                          ** unit : mmW/degC/d
    #'                          ** uri :
    #'            * name: tavg
    #'                          ** description : average temperature
    #'                          ** inputtype : variable
    #'                          ** variablecategory : auxiliary
    #'                          ** datatype : DOUBLE
    #'                          ** default : 0.0
    #'                          ** min : 0.0
    #'                          ** max : 100.0
    #'                          ** unit : degC
    #'                          ** uri :
    #'- outputs:
    #'            * name: M
    #'                          ** description : snow in the process of melting
    #'                          ** variablecategory : rate
    #'                          ** datatype : DOUBLE
    #'                          ** min : 0.0
    #'                          ** max : 500.0
    #'                          ** unit : mmW/d
    #'                          ** uri :
    M <- 0.0
    K <- DKmax / 2.0 * -sin((2.0 * pi * as.double(jul) / 366.0 + (9.0 / 16.0 * pi))) + Kmin + (DKmax / 2.0)
    if (tavg > Tmf)
    {
        M <- K * (tavg - Tmf)
    }
    return (list('M' = M))
}


### We want a piece-wise approximation of asin(x)
### But we want to have the following constraints:
### 1) each should be completely well behaved in its range
### 2) adjacent pieces will be blended using linear approximation so their regions should overlap
### 3) the blended result should have continuity
### 3) symmetry will be handled outside this approximation
### 4) the overall range handled should start at 0 and end before 1
### 5) the overall should be as large as possible, but need not reach 1

fit = function(param) {
    c0.high = param[1]
    c1.high = param[2]
    c2.low = param[3]
    c2.high = param[4]
    c3.low = param[5]
    c3.high = param[6]
    c4.low = param[7]

    x = seq(-c0.high, c0.high, by=0.01)
    d0 = data.frame(y=asin(x), x=x, x2=x*x, x3=x*x*x, i1=1/(1-x), i2=1/(1-x)/(1-x))
    m0 = glm(y ~ x + x2 + x3 + i1 + i2, d0, family='gaussian')

    x = seq(0, c1.high, by=0.01)
    d1 = data.frame(y=asin(x), x=x, x2=x*x, x3=x*x*x, i1=1/(1-x), i2=1/(1-x)/(1-x))
    m1 = glm(y ~ x + x2 + x3 + i1 + i2, d1, family='gaussian')

    x = seq(c2.low, c2.high, by=0.01)
    d2 = data.frame(y=asin(x), x=x, x2=x*x, x3=x*x*x, i1=1/(1-x), i2=1/(1-x)/(1-x))
    m2 = glm(y ~ x + x2 + x3 + i1 + i2, d2, family='gaussian')

    x = seq(c3.low, c3.high, by=0.01)
    d3 = data.frame(y=asin(x), x=x, x2=x*x, x3=x*x*x, i1=1/(1-x), i2=1/(1-x)/(1-x))
    m3 = glm(y ~ x + x2 + x3 + i1 + i2, d3, family='gaussian')

    list(m0=m0,m1=m1,m2=m2,m3=m3,
         c0.high=c0.high,c1.high=c1.high, c2.low=c2.low, c2.high=c2.high,
         c3.low=c3.low, c3.high=c3.high, c4.low=c4.low)
}

follow = function(models) {
    x = seq(0, models$c3.high, by=0.01)
    data = data.frame(x=x, x2=x*x, x3=x*x*x, i1=1/(1-x), i2=1/(1-x)/(1-x))
    raw = data.frame(
        y0=predict(models$m0, newdata=data),
        y1=predict(models$m1, newdata=data),
        y2=predict(models$m2, newdata=data),
        y3=predict(models$m3, newdata=data),
        y4=asin(x)
    )

    ## c0.high, c1.high, c2.low, c1.high, c3.low, c2.high, c3.high, c4.low
    mix = with(models, {
         mix = matrix(0, nrow=dim(raw)[1], ncol=5)
         x0 = bound((c0.high - x) / c0.high)
         x1 = bound((c1.high - x) / (c1.high - c2.low));
         x2 = bound((c2.high - x) / (c2.high - c3.low));
         x3 = bound((c3.high - x) / (c3.high - c4.low));

         mix[, 1] = x0
         mix[, 2] = (1-x0) * x1
         mix[, 3] = (1-x1) * x2
         mix[, 4] = (1-x2) * x3
         mix[, 5] = 1-x3
         mix
     })

    data.frame(x=x, yhat=rowSums(raw * mix), y=asin(x))
}

bound = function(v) {
    over = v > 1
    under = v < 0
    v * (1-over) * (1-under) + over
}


/*
 * fmath.r -- sin, cos, tan, acos, asin, atan, dtor, rtod, exp, log, sqrt
 */

/*
 * Most of the math ops are simple calls to underlying C functions,
 * sometimes with additional error checking to avoid and/or detect
 * various C runtime errors.
 */
#begdef MathOp(funcname,ccode,comment,pre,post)
#funcname "(r)" comment
function{1} funcname(x)

   if !cnv:C_double(x) then
      runerr(102, x)

   abstract {
      return real
      }
   inline {
      double y;
      pre		/* Pre math-operation range checking */
      errno = 0;
      y = ccode(x);
      post		/* Post math-operation C library error detection */
      return C_double y;
      }
end
#enddef

#define aroundone if (x < -1.0 || x > 1.0) {drunerr(205, x); errorfail;}
#define positive  if (x < 0)               {drunerr(205, x); errorfail;}

#define erange    if (errno == ERANGE)     runerr(204);
#define edom      if (errno == EDOM)       runerr(205);

MathOp(sin, sin,  ", x in radians.", ;, ;)
MathOp(cos, cos,  ", x in radians.", ;, ;)
MathOp(tan, tan,  ", x in radians.", ; , erange)
MathOp(acos,acos, ", x in radians.", aroundone, edom)
MathOp(asin,asin, ", x in radians.", aroundone, edom)

#if NT
double atanh(double x)
{
   return 0.5 * 2.302585093 * log((1 + x) / (1 - x));
}
#endif

MathOp(atanh,atanh, ", x in radians.", aroundone, edom)
MathOp(exp, exp,  " - e^x.", ; , erange)
MathOp(sqrt,sqrt, " - square root of x.", positive, edom)
#define DTOR(x) ((x) * Pi / 180)
#define RTOD(x) ((x) * 180 / Pi)
MathOp(dtor,DTOR, " - convert x from degrees to radians.", ; , ;)
MathOp(rtod,RTOD, " - convert x from radians to degrees.", ; , ;)

"atan(r1,r2) -- r1, r2  in radians; if r2 is present, produces atan2(r1,r2)."

function{1} atan(x,y)

   if !cnv:C_double(x) then
      runerr(102, x)

   abstract {
      return real
      }
   if is:null(y) then
      inline {
         return C_double atan(x);
         }
   if !cnv:C_double(y) then
      runerr(102, y)
   inline {
      return C_double atan2(x,y);
      }
end

"log(r1,r2) - logarithm of r1 to base r2."

function{1} log(x,b)

   if !cnv:C_double(x) then
      runerr(102, x)

   abstract {
      return real
      }
   inline {
      if (x <= 0.0) {
         drunerr(205, x);
         errorfail;
         }
      }
   if is:null(b) then
      inline {
         return C_double log(x);
         }
   else {
      if !cnv:C_double(b) then
         runerr(102, b)
      body {
#ifndef Concurrent
         static double lastbase = 0.0;
         static double divisor;
#endif					/* Concurrent */
	 CURTSTATE();

         if (b <= 1.0) {
            drunerr(205, b);
            errorfail;
            }
         if (b != lastbase) {
            divisor = log(b);
            lastbase = b;
            }
	 x = log(x) / divisor;
         return C_double x;
         }
      }
end

"max(x,y,...) - return the maximum of the arguments"

function{1} max(argv[argc])
abstract {
   return any_value
   }
body {
   int i;
   struct descrip dtmp;
   if (argc == 0) fail;
   dtmp = argv[0];
   if (argc == 1) {
      if (is:list(dtmp)) {
	 int i, j, size;
	 union block *bp;
	 size = BlkD(dtmp,List)->size;
	 if (size==0) fail;
#ifdef Arrays
	 if (BlkD(dtmp,List)->listtail == NULL) {
	    bp = BlkD(dtmp,List)->listhead;
	    if (bp->Intarray.title == T_Intarray) {
	       word mymax = bp->Intarray.a[0];
	       for(i = 1; i < size; i++)
		  if (bp->Intarray.a[i] > mymax) mymax = bp->Intarray.a[i];
	       return C_integer mymax;
	       }
	    else {
	       double mymax = bp->Realarray.a[0];
	       for(i = 1; i < size; i++)
		  if (bp->Realarray.a[i] > mymax) mymax = bp->Realarray.a[i];
	       dtmp.dword = D_Real;
#ifdef DescriptorDouble
	       dtmp.vword.realval = mymax;
#else					/* DescriptorDouble */
	       dtmp.vword.bptr = (union block *)alcreal(mymax);
#endif					/* DescriptorDouble */
	       return dtmp;
	       }
	    }

#endif
	 /*
	  * normal max(L), walk through list elements
	  */
	 bp = dtmp.vword.bptr;
	 dtmp = nulldesc; /* the minimal value */
	 for (bp = Blk(bp,List)->listhead; BlkType(bp) == T_Lelem;
	      bp = Blk(bp,Lelem)->listnext) {
	    for (i = 0; i < Blk(bp,Lelem)->nused; i++) {
	       j = bp->Lelem.first + i;
	       if (j >= bp->Lelem.nslots)
		  j -= bp->Lelem.nslots;
	       if (anycmp(bp->Lelem.lslots+j, &dtmp) == Greater)
		  dtmp = bp->Lelem.lslots[j];
	       }
	    }
	 }
      }
   else
      for(i=1;i<argc;i++) if (anycmp(&dtmp, argv+i) < 0) dtmp = argv[i];
   return dtmp;
   }
end

"min(x,y,...) - return the minimum of the arguments"

function{1} min(argv[argc])
abstract {
   return any_value
   }
body {
   int i;
   struct descrip dtmp;
   if (argc == 0) fail;
   dtmp = argv[0];
   if (argc == 1) {
      if (is:list(dtmp)) {
	 int i, j, size;
	 union block *bp;
	 size = BlkD(dtmp,List)->size;
	 if (size==0) fail;
#ifdef Arrays
	 if (BlkD(dtmp,List)->listtail == NULL) {
	    bp = BlkD(dtmp,List)->listhead;
	    if (bp->Intarray.title == T_Intarray) {
	       word mymin = bp->Intarray.a[0];
	       for(i = 1; i < size; i++)
		  if (bp->Intarray.a[i] < mymin) mymin = bp->Intarray.a[i];
	       return C_integer mymin;
	       }
	    else {
	       double mymin = bp->Realarray.a[0];
	       for(i = 1; i < size; i++)
		  if (bp->Realarray.a[i] < mymin) mymin = bp->Realarray.a[i];
	       dtmp.dword = D_Real;
#ifdef DescriptorDouble
	       dtmp.vword.realval = mymin;
#else					/* DescriptorDouble */
	       dtmp.vword.bptr = (union block *)alcreal(mymin);
#endif					/* DescriptorDouble */
	       return dtmp;
	       }
	    }

#endif
	 /*
	  * normal min(L), walk through list elements
	  */
	 bp = dtmp.vword.bptr;
	 dtmp = nulldesc;
	 for (bp = Blk(bp,List)->listhead; BlkType(bp) == T_Lelem;
	      bp = Blk(bp,Lelem)->listnext) {
	    for (i = 0; i < Blk(bp,Lelem)->nused; i++) {
	       j = bp->Lelem.first + i;
	       if (j >= bp->Lelem.nslots)
		  j -= bp->Lelem.nslots;
		  dtmp = bp->Lelem.lslots[j]; /* the minimal value for now */
		  break;break;
	       }
	    }

	 for (bp = Blk(bp,List)->listhead; BlkType(bp) == T_Lelem;
	      bp = Blk(bp,Lelem)->listnext) {
	    for (i = 0; i < Blk(bp,Lelem)->nused; i++) {
	       j = bp->Lelem.first + i;
	       if (j >= bp->Lelem.nslots)
		  j -= bp->Lelem.nslots;
	       if (anycmp(bp->Lelem.lslots+j, &dtmp) == Less)
		  dtmp = bp->Lelem.lslots[j];
	       }
	    }
	 }
      }
   else
      for(i=1;i<argc;i++) if (anycmp(&dtmp, argv+i) > 0) dtmp = argv[i];
   return dtmp;
   }
end


# file score could be produced by function implemented in permutationLsqLambdaK
# this script is used to estimate the K and lambda value to calculate E-value and P-value

data1 = read.table("randomScores")
u = unique(data1$V1)
s = u[order(u)]

data = data.frame(x=s, y=s)
for ( i in 1:length(s) ){
	data[i, 2] =  length(which(data1$V1 >= data$x[i])) / nrow(data1)
}
x=data$x
y=data$y
library(minpack.lm)
nonlin_mod=nlsLM(y~(1-exp(-1*k*1000000*exp(-1*l*x))), control=nls.lm.control(maxiter=550), start=list(k=0.3, l=0.2))
plot(x, y, xlab="s", ylab="p-value")
lines(x,predict(nonlin_mod),col="red")
nonlin_mod

4000000
nonlin_mod
Nonlinear regression model
  model: y ~ (1 - exp(-1 * k * 4e+06 * exp(-1 * l * x)))
   data: parent.frame()
       k        l
0.001959 0.344325
 residual sum-of-squares: 0.003286

Number of iterations to convergence: 25
Achieved convergence tolerance: 1.49e-08

1000000
nonlin_mod
Nonlinear regression model
  model: y ~ (1 - exp(-1 * k * 1e+06 * exp(-1 * l * x)))
   data: parent.frame()
       k        l
0.006662 0.382291
 residual sum-of-squares: 0.001207

Number of iterations to convergence: 29
Achieved convergence tolerance: 1.49e-08

## for masking
1000000
nonlin_mod
Nonlinear regression model
  model: y ~ (1 - exp(-1 * k * 1e+06 * exp(-1 * l * x)))
   data: parent.frame()
      k       l
0.01011 0.38877
 residual sum-of-squares: 0.0002461

Number of iterations to convergence: 25
Achieved convergence tolerance: 1.49e-08

int matchingScore = 2;
int mismatchingPenalty = -3;
int openGapPenalty = -3;
int extendGapPenalty = -1;

data1 = read.table("score")
u = unique(data1$V1)
s = u[order(u)]

data = data.frame(x=s, y=s)
for ( i in 1:length(s) ){
	data[i, 2] =  length(which(data1$V1 >= data$x[i])) / nrow(data1)
}
x=data$x
y=data$y
library(minpack.lm)
nonlin_mod=nlsLM(y~(1-exp(-1*k*1000000*exp(-1*l*x))), control=nls.lm.control(maxiter=550), start=list(k=0.3, l=0.2))
plot(x, y, xlab="s", ylab="p-value")
lines(x,predict(nonlin_mod),col="red")

nonlin_mod

Nonlinear regression model
  model: y ~ (1 - exp(-1 * k * 1e+06 * exp(-1 * l * x)))
   data: parent.frame()
        k         l
1.807e-05 5.740e-02
 residual sum-of-squares: 0.001187

Number of iterations to convergence: 32
Achieved convergence tolerance: 1.49e-08


model_diffusionlimitedevaporation <- function (deficitOnTopLayers = 5341.0,
         soilDiffusionConstant = 4.2){
    #'- Name: DiffusionLimitedEvaporation -Version: 1.0, -Time step: 1
    #'- Description:
    #'            * Title: DiffusionLimitedEvaporation Model
    #'            * Author: Pierre Martre
    #'            * Reference:  From the wheat simulation model SiriusQuality
    #'                    Published in 2009
    #'                    doi:http://dx.doi.org/10.1016/j.eja.2006.04.007
    #'
    #'            * Institution: INRA Montpellier
    #'            * Abstract: the evaporation from the diffusion limited soil when the surface has
    #'            dried sufficiently to provide a significant barrier to water vapor diffusion
    #'
    #'- inputs:
    #'            * name: deficitOnTopLayers
    #'                          ** description : deficit On TopLayers
    #'                          ** variablecategory : auxiliary
    #'                          ** datatype : DOUBLE
    #'                          ** default : 5341
    #'                          ** min : 0
    #'                          ** max : 10000
    #'                          ** unit : g m-2 d-1
    #'                          ** uri : http://www1.clermont.inra.fr/siriusquality/?page_id=547
    #'                          ** inputtype : variable
    #'            * name: soilDiffusionConstant
    #'                          ** description : soil Diffusion Constant
    #'                          ** parametercategory : soil
    #'                          ** datatype : DOUBLE
    #'                          ** default : 4.2
    #'                          ** min : 0
    #'                          ** max : 10
    #'                          ** unit :
    #'                          ** uri : http://www1.clermont.inra.fr/siriusquality/?page_id=547
    #'                          ** inputtype : parameter
    #'- outputs:
    #'            * name: diffusionLimitedEvaporation
    #'                          ** description : the evaporation from the diffusion limited soil
    #'                          ** variablecategory : state
    #'                          ** datatype : DOUBLE
    #'                          ** min : 0
    #'                          ** max : 5000
    #'                          ** unit : g m-2 d-1
    #'                          ** uri : http://www1.clermont.inra.fr/siriusquality/?page_id=547
    if (deficitOnTopLayers / 1000.0 <= 0.0)
    {
        diffusionLimitedEvaporation <- 8.3 * 1000.0
    }
    else
    {
        if (deficitOnTopLayers / 1000.0 < 25.0)
        {
            diffusionLimitedEvaporation <- 2.0 * soilDiffusionConstant * soilDiffusionConstant / (deficitOnTopLayers / 1000.0) * 1000.0
        }
        else
        {
            diffusionLimitedEvaporation <- 0.0
        }
    }
    return (list('diffusionLimitedEvaporation' = diffusionLimitedEvaporation))
}


forwarddif <- function(a, n) {
  if ( n == 1 )
    a[2:length(a)] - a[1:length(a)-1]
  else {
    r <- forwarddif(a, 1)
    forwarddif(r, n-1)
  }
}

fdiff <- function(a, n) {
  r <- a
  for(i in 1:n) {
    r <- r[2:length(r)] - r[1:length(r)-1]
  }
  r
}

v <- c(90, 47, 58, 29, 22, 32, 55, 5, 55, 73)

print(forwarddif(v, 9))
print(fdiff(v, 9))


 DGGEVX Example Program Results

 Eigenvalue( 1) =     2.00000

 Eigenvector( 1)
     0.99606
     0.00569
     0.06261
     0.06261

 Eigenvalue( 2) = (    3.00000,   -4.00000)

 Eigenvector( 2)
 (    0.94491,   -0.00000)
 (    0.18898,    0.00000)
 (    0.11339,    0.15119)
 (    0.11339,    0.15119)

 Eigenvalue( 3) = (    3.00000,    4.00000)

 Eigenvector( 3)
 (    0.94491,    0.00000)
 (    0.18898,   -0.00000)
 (    0.11339,   -0.15119)
 (    0.11339,   -0.15119)

 Eigenvalue( 4) =     4.00000

 Eigenvector( 4)
     0.98752
     0.01097
    -0.03292
     0.15361


#simulations for 'Covariate adjustment and estimation of mean response in randomised trials'
#Jonathan Bartlett

library(MASS)
library(sandwich)
library(blockrand)

expit <- function(x) {
  exp(x)/(1+exp(x))
}

#define function which runs simulations

runNegBinSim <- function(nSim, n, b0, bx, bz, bxz, gammadisp, nbwm,randtype) {
  muhat1 <- array(0, dim=c(nSim,2))
  varest1 <- array(0, dim=c(nSim,3))

  muhat2 <- array(0, dim=c(nSim))
  varest2 <- array(0, dim=c(nSim,2))

  muhat3 <- array(0, dim=c(nSim))
  varest3 <- array(0, dim=c(nSim))

  for (sim in 1:nSim) {
    print(sim)

    x <- 1*(runif(n)<0.5)
    if (randtype==1) {
      #simple randomisation
      z <- 1*(runif(n)<0.5)
    } else if (randtype==2) {
      #random permuted block randomisation
      rand <- blockrand(n=n, num.levels=2)
      z <- as.numeric(rand$treatment)[1:n]-1
    } else if (randtype==3) {
      #stratified random permuted block
      z <- x
      n0 <- sum(x==0)
      z[x==0] <- as.numeric(blockrand(n=n0, num.levels=2)$treatment)[1:n0]-1
      n1 <- sum(x==1)
      z[x==1] <- as.numeric(blockrand(n=n1, num.levels=2)$treatment)[1:n1]-1
    }

    xb <- b0+bx*(x-0.5)+bz*(z-0.5)+bxz*(x-0.5)*(z-0.5)
    #specify shape of gamma
    k <- 2
    if (gammadisp==T) {
      #shape k
      gamma <- rgamma(n, k, k)
    } else {
      #we use log normal which has mean 1 and variance matching the gamma variance
      gamma <- exp(rnorm(n,-0.5*log(1+1/k),(log(1+1/k))^0.5))
    }

    #simulate follow-up time
    t <- rep(1,n)
    shortFup <- 1*(runif(n)<0.25)
    t[shortFup] <- runif(sum(shortFup))

    y <- rpois(n, t*gamma*exp(xb))

    simdata <- data.frame(y,x,z)

    if (nbwm==T) {
      mod <- glm.nb(y~x+z+offset(log(t)))
    } else {
      mod <- glm(y~x+z+offset(log(t)), family="poisson")
    }

    #calculate predictions for z=1
    pihat <- mean(z)

    #muhat1
    muhat1[sim,1] <- sum(y[z==1])/sum(t[z==1])
    #standard SE for this
    varest1[sim,1] <- (pihat^(-2))*(mean(t[z==1]))^(-2)*mean((z*(y-muhat1[sim,1]))^2)/n

    #muhat2
    activePredxb <- cbind(rep(1,n),x,rep(1,n)) %*% coef(mod)
    activePred <- exp(activePredxb)
    muhat2[sim] <- mean(activePred)
    #calculate delta method variances
    outer <- colMeans(as.numeric(exp(activePredxb)) * cbind(1,x,rep(1,n)))
    outer <- array(outer, dim=c(3,1))
    #sandwich variance treating covariates as fixed
    varest2[sim,1] <- t(outer) %*% vcovHC(mod, type = "HC0") %*% outer
    #variance estimator accounting random X assuming model correct
    varest2[sim,2] <- varest2[sim,1] + sum((activePred-muhat2[sim])^2)/(n^2)

    #muhat3
    muhat3[sim] <- muhat1[sim,1] - mean(((z-pihat)/pihat)*activePred)
    #variance of muhat3
    tauz <- mean(t[z==1])
    varest3[sim] <- (pihat^(-2))*tauz^(-2)*mean((z*(y-muhat3[sim]) -tauz*(z-pihat)*(activePred-muhat2[sim]) )^2)/n

  }

  list(muhat1=muhat1, muhat2=muhat2, muhat3=muhat3, varest1=varest1, varest2=varest2, varest3=varest3)

}

set.seed(698123)

nSim <- 10000
n <- 400

simRuns <- vector("list", 4)

simRuns[[1]] <- runNegBinSim(nSim=nSim,n=n,b0=0,bx=3,bz=1,bxz=0,gammadisp=T,nbwm=T,randtype=2)
#log normal dispersion parameter, but conditional mean model correct
simRuns[[2]] <- runNegBinSim(nSim=nSim,n=n,b0=0,bx=3,bz=1,bxz=0,gammadisp=F,nbwm=T,randtype=2)
#now conditional mean model wrong, gamma distributed dispersion
simRuns[[3]] <- runNegBinSim(nSim=nSim,n=n,b0=0,bx=3,bz=1,bxz=-1.5,gammadisp=T,nbwm=T,randtype=2)
#now use a Poisson working model
simRuns[[4]] <- runNegBinSim(nSim=nSim,n=n,b0=0,bx=3,bz=1,bxz=-1.5,gammadisp=T,nbwm=F,randtype=2)

resultPrint <- function(resultSet) {
  c(mean(resultSet$muhat1[,1]),
    100*mean((resultSet$muhat1[,1]*exp(-1.96*resultSet$varest1[,1]^0.5 / resultSet$muhat1[,1])<mean(resultSet$muhat1[,1])) &
      (resultSet$muhat1[,1]*exp(1.96*resultSet$varest1[,1]^0.5 / resultSet$muhat1[,1])>mean(resultSet$muhat1[,1]))),
    mean(resultSet$muhat2)-mean(resultSet$muhat1[,1]),
    var(resultSet$muhat1[,1])/var(resultSet$muhat2),
    100*mean((resultSet$muhat2*exp(-1.96*resultSet$varest2[,1]^0.5 / resultSet$muhat2)<mean(resultSet$muhat1[,1])) &
           (resultSet$muhat2*exp(1.96*resultSet$varest2[,1]^0.5 / resultSet$muhat2)>mean(resultSet$muhat1[,1]))),
    100*mean((resultSet$muhat2*exp(-1.96*resultSet$varest2[,2]^0.5 / resultSet$muhat2)<mean(resultSet$muhat1[,1])) &
           (resultSet$muhat2*exp(1.96*resultSet$varest2[,2]^0.5 / resultSet$muhat2)>mean(resultSet$muhat1[,1]))),
    mean(resultSet$muhat3)-mean(resultSet$muhat1[,1]),
    var(resultSet$muhat1[,1])/var(resultSet$muhat3),
    100*mean((resultSet$muhat3*exp(-1.96*resultSet$varest3^0.5 / resultSet$muhat3)<mean(resultSet$muhat1[,1])) &
           (resultSet$muhat3*exp(1.96*resultSet$varest3^0.5 / resultSet$muhat3)>mean(resultSet$muhat1[,1]))))
}

resTable <- matrix(unlist(lapply(simRuns, resultPrint)), byrow=F, ncol=length(simRuns))
colnames(resTable) <- c("Scenario 1", "Scenario 2", "Scenario 3", "Scenario 4")
rownames(resTable) <- c("Mean $\\hat{\\mu}_{1}(1)$", "95\\% CI Cov.",
                         "Bias $\\hat{\\mu}_{2}(1)$", "Rel. eff.",
                          "Fixed $X$ 95\\% CI Cov.","Random $X$ 95\\% CI Cov.",
                         "Bias $\\hat{\\mu}_{3}(1)$", "Rel. eff.", "95\\% CI Cov.")

library(xtable)
print(xtable(data.frame(row = rownames(resTable),data.frame(resTable)), digits=2),sanitize.text.function=function(x){x}, include.rownames = F)

#stratified randomisation

simRuns2 <- vector("list", 4)

simRuns2[[1]] <- runNegBinSim(nSim=nSim,n=n,b0=0,bx=3,bz=1,bxz=0,gammadisp=T,nbwm=T,randtype=3)
#log normal dispersion parameter, but conditional mean model correct
simRuns2[[2]] <- runNegBinSim(nSim=nSim,n=n,b0=0,bx=3,bz=1,bxz=0,gammadisp=F,nbwm=T,randtype=3)
#now conditional mean model wrong, gamma distributed dispersion
simRuns2[[3]] <- runNegBinSim(nSim=nSim,n=n,b0=0,bx=3,bz=1,bxz=-1.5,gammadisp=T,nbwm=T,randtype=3)
#now use a Poisson working model
simRuns2[[4]] <- runNegBinSim(nSim=nSim,n=n,b0=0,bx=3,bz=1,bxz=-1.5,gammadisp=T,nbwm=F,randtype=3)

resultPrint <- function(resultSet) {
  c(mean(resultSet$muhat1[,1]),
    100*mean((resultSet$muhat1[,1]*exp(-1.96*resultSet$varest1[,1]^0.5 / resultSet$muhat1[,1])<mean(resultSet$muhat1[,1])) &
               (resultSet$muhat1[,1]*exp(1.96*resultSet$varest1[,1]^0.5 / resultSet$muhat1[,1])>mean(resultSet$muhat1[,1]))),
    mean(resultSet$muhat2)-mean(resultSet$muhat1[,1]),
    var(resultSet$muhat1[,1])/var(resultSet$muhat2),
    100*mean((resultSet$muhat2*exp(-1.96*resultSet$varest2[,1]^0.5 / resultSet$muhat2)<mean(resultSet$muhat1[,1])) &
               (resultSet$muhat2*exp(1.96*resultSet$varest2[,1]^0.5 / resultSet$muhat2)>mean(resultSet$muhat1[,1]))),
    100*mean((resultSet$muhat2*exp(-1.96*resultSet$varest2[,2]^0.5 / resultSet$muhat2)<mean(resultSet$muhat1[,1])) &
               (resultSet$muhat2*exp(1.96*resultSet$varest2[,2]^0.5 / resultSet$muhat2)>mean(resultSet$muhat1[,1]))),
    mean(resultSet$muhat3)-mean(resultSet$muhat1[,1]),
    var(resultSet$muhat1[,1])/var(resultSet$muhat3),
    100*mean((resultSet$muhat3*exp(-1.96*resultSet$varest3^0.5 / resultSet$muhat3)<mean(resultSet$muhat1[,1])) &
               (resultSet$muhat3*exp(1.96*resultSet$varest3^0.5 / resultSet$muhat3)>mean(resultSet$muhat1[,1]))))
}

resTable <- matrix(unlist(lapply(simRuns2, resultPrint)), byrow=F, ncol=length(simRuns2))
colnames(resTable) <- c("Scenario 1", "Scenario 2", "Scenario 3", "Scenario 4")
rownames(resTable) <- c("Mean $\\hat{\\mu}_{1}(1)$", "95\\% CI Cov.",
                        "Bias $\\hat{\\mu}_{2}(1)$", "Rel. eff.",
                        "Fixed $X$ 95\\% CI Cov.","Random $X$ 95\\% CI Cov.",
                        "Bias $\\hat{\\mu}_{3}(1)$", "Rel. eff.", "95\\% CI Cov.")

print(xtable(data.frame(row = rownames(resTable),data.frame(resTable)), digits=2),sanitize.text.function=function(x){x}, include.rownames = F)


library('OpenMx')

setwd('~/git/sem_python/tests')
# data <- read.csv('PoliticalDemocracy_missing.csv')
data <- read.csv('PoliticalDemocracy.csv')

ind60 <- c('x1', 'x2', 'x3')
dem60 <- c('y1', 'y2', 'y3', 'y4')
dem65 <- c('y5', 'y6', 'y7', 'y8')
manifest <- c(ind60, dem60, dem65)
latent <- c('ind60', 'dem60', 'dem65')
data <- data[manifest]

model <- mxModel(
    "PoliticalDemocracy",
    type="RAM",
    manifestVars=manifest,
    latentVars=latent,
    mxData(observed=data, type="raw"),
    mxPath(from=manifest, arrows=2, free=TRUE, values=diag(var(data, na.rm=TRUE)) / 2),
    mxPath(from='y1', to='y5', arrows=2, free=TRUE, values=0),
    mxPath(from='y3', to='y7', arrows=2, free=TRUE, values=0),
    mxPath(from='y2', to=c('y4', 'y6'), arrows=2, free=TRUE, values=0),
    mxPath(from='y4', to='y6', arrows=2, free=TRUE, values=0),
    mxPath(from='y6', to='y8', arrows=2, free=TRUE, values=0),
    mxPath(from=latent, arrows=2, free=FALSE, values=1),

    mxPath(from='ind60', to='dem60', arrows=1, free=TRUE, values=1, labels='ind60_dem60'),
    mxPath(from='ind60', to='dem65', arrows=1, free=TRUE, values=1, labels='ind60_dem65'),
    mxPath(from='dem60', to='dem65', arrows=1, free=TRUE, values=1, labels='dem60_dem65'),

    mxPath(from="ind60", to=ind60, arrows=1, free=TRUE, values=1, labels=c('indo60_x1', 'ind60_x2', 'ind60_x3')),
    mxPath(from="dem60", to=dem60, arrows=1, free=TRUE, values=1, labels=c('dem60_y1', 'dem60_y2', 'dem60_y3', 'dem60_y4')),
    mxPath(from="dem65", to=dem65, arrows=1, free=TRUE, values=1, labels=c('dem65_y1', 'dem65_y2', 'dem65_y3', 'dem65_y4')),
    mxPath(from='one', to=manifest, free=TRUE, values=colMeans(data, na.rm=TRUE)))

fit <- mxRun(model)

summary(fit)


#' @title calcHMImmersedTransomRes
#'
#' @description
#' Calculate additional pressure resistance due to immersed transom (\code{Rtr})
#' (kN).
#'
#' @param shipSpeed Ship actual speed (vector of numericals, m/s) (see
#'  \code{\link{calcSpeedUnitConversion}})
#' @param breadth Moulded breadth (vector of numericals, m)
#' @param Cwp Water plane area coefficient (vector of numericals, see
#'  \code{\link{calcCwp}})
#' @param maxDraft Maximum summer load line draft (vector of numericals, m)
#' @param At Transom area (vector of numericals, m^2) (see \code{\link{calcAt}})
#' @param seawaterDensity Sea water density. Default = 1.025 (g/cm^3). Can
#' supply either a vector of numericals, a single number, or rely on the default
#'
#' @return \code{Rtr} (vector of numericals, kN)
#'
#' @references
#'Holtrop, J. and Mennen, G. G. J. 1982. "An approximate power prediction
#'method." International Shipbuilding Progress 29.
#'
#'@seealso \itemize{
#'\item \code{\link{calcSpeedUnitConversion}}
#'\item \code{\link{calcCwp}}
#'\item \code{\link{calcAt}} }
#'
#' @family Holtrop-Mennen Calculations
#' @family Resistance Calculations
#'
#' @examples
#' calcHMImmersedTransomRes(seq(1,5,1),32.25,0.91,13.57,22.2,seawaterDensity=1.025)
#'
#' @export

calcHMImmersedTransomRes<-function(shipSpeed,breadth,Cwp,maxDraft,At,seawaterDensity=1.025){

Rtr<-
ifelse(shipSpeed/sqrt(2*9.81*At/(breadth+breadth*Cwp))<5,#case 1
  0.5*seawaterDensity*(shipSpeed^2)*At*(0.2*(1-0.2*(
    shipSpeed/sqrt(2*9.81*At/(breadth+breadth*Cwp))
    )
    ))
,#case 2
0)

return(Rtr)
}


#' Simulations from day-to-day stochastic process models for traffic
#'
#' This functions generartes sequences of traffic flow patterns drawn from one of a number of day-to-day stochastic process models.
#' @param ODdemand Vector of origin-destination (OD) travel demands
#' @param ODpair Vector indicating the OD pair serviced by each route (ordered by columns of the path-link incidence matrix, A).
#' @param A Path-link incidence matrix
#' @param N.days Number of days to simulate. Defaults to 100.
#' @param N.sim Number of parallel simulation runs. Defaults to 1.
#' @param x.start Initial route flow pattern. Defaults to NA, when the initial flow is set to SUE.
#' @param Alpha Vector of free flow travel time parameters for each link
#' @param Beta Vector of capacity parameters for each link
#' @param pow Polynomial order of cost function for each link. Defaults to 4.
#' @param RUM Choice of random utility model. Can be "logit" (the default) or "probit".
#' @param theta A dispersion parameter. For the logit model, a single value specifying the logit parameter. For the probit model, a vector of standard deviations for the individual link cost errors. Defaults to 1.
#' @param psi Recency parameter, controlling weight assigned to most recent path costs when updating disutility. Defaults to 0.05.
#' @param process Defaults to "Standard", when a time-homogeneous Markoc process is employed in which route choice decisions are based on a utility which is a convex combination of the previous disutility and route costs. Alternatives are "TIDDS1" and "TIDDS2" time-inhomogeneous processes.
#' @variable.demand If FALSE (the default), travel demand is static through time. If TRUE, then travel demand is subject to Poisson variation with mean specified by \code{ODdemand}
#' @param prob.model Route choice probability model. One of "ProductMN" (product multinomial, the default), "Poisson", and "Approximate" (a quick and dirty approximation to the others).
#' @param tol Tolerance for convergence assessment for SUE. USed if \code{x.start} not specified. Defaults to 1e-4.
#' @param verbose Should progress of SUE algorithm be printed out? Defaults to FALSE.
#' @return The output is a list with components x and u, containing traffic path flows and disutilies respectively. Both x and u are 3-dimensional arrays. The first dimension indexes simulation run (if multiple parallel runs are required); the second indexes network path; and the third indexes day.
#' @keywords Day-to-day stochastic traffic assignment process
#' @examples
#' A <- matrix(c(0,1,0,0,1,0,0,0,0,1,1,0,0,0,1,0,0,0,0,1,1,0,0,0,0,0,0,1),ncol=4,byrow=T)
#' Alpha <- rep(10,7)
#' Beta <- rep(50,7)
#' pow <- rep(4,7)
#' ODpair <- c(1,1,2,2)
#' ODdemand <- c(50,50)
#' theta <- 0.7
#' N.sim <- 1
#' N.days <- 100
#' rDDSProcess(ODdemand,ODpair,A,N.days=N.days,N.sim=N.sim,x.start=c(20,0),Alpha=Alpha,Beta=Beta,pow=pow,RUM="logit",theta=theta,process="TIDDS1",variable.demand=F)
#' rDDSProcess(ODdemand,ODpair,A,N.days=N.days,N.sim=N.sim,x.start=c(20,0),Alpha=Alpha,Beta=Beta,pow=pow,RUM="logit",theta=theta,process="TIDDS2",variable.demand=F)
#' rDDSProcess(ODdemand,ODpair,A,N.days=N.days,N.sim=N.sim,x.start=c(20,0),Alpha=Alpha,Beta=Beta,pow=pow,RUM="logit",theta=theta,process="Standard",variable.demand=F)
#' @export

rDDSProcess <- function(ODdemand,ODpair,A,N.days=100,N.sim=1,x.start=NA,Alpha,Beta,pow=4,RUM="logit",theta=1,psi=0.05,process="Standard",variable.demand=F,tol=1e-4,verbose=F){
	psi.change <- process=="TIDDS1" | process=="TIDDS2"
	N.routes <- ncol(A)
  	N.OD <- length(ODdemand)
  	N.routes.per.OD <- unname(table(ODpair))
	if (variable.demand) mean.ODdemand <- ODdemand
  	ODdemand.rep <- rep(ODdemand,N.routes.per.OD)
  	indices <- c(0,cumsum(N.routes.per.OD))
  	x.sim <- array(0,dim=c(N.sim,N.routes,N.days))
  	u.sim <- array(0,dim=c(N.sim,N.routes,N.days))
    	if(any(is.na(x.start))){
		if (variable.demand) ODdemand <- rpois(N.OD,mean.ODdemand)
		x.start <- SUE(ODdemand=ODdemand,ODpair=ODpair,A=A,Alpha=Alpha,Beta=Beta,pow=pow,RUM=RUM,theta=theta,tol=tol,verbose=verbose)$x
    	}
	u.start <- PathCost(x.start,A=A,Alpha=Alpha,Beta=Beta,pow=pow)
	for (ii in 1:N.sim){
 		x.sim[ii,,1] <- x.start
		u.sim[ii,,1] <- u.start
		if (process=="TIDDS1") xbar <- x.start
		for (tt in 2:(N.days)){
			if (variable.demand) ODdemand <- rpois(N.OD,mean.ODdemand)
			if(psi.change) psi <- 1/tt
			if (process!="TIDDS1"){
	      		cost <- PathCost(x.sim[ii,,tt-1],A=A,Alpha=Alpha,Beta=Beta,pow=pow)
      			u <- psi*cost + (1-psi)*u.sim[ii,,tt-1]
			}
			if (process=="TIDDS1"){
				xbar <- (1-psi)*xbar + psi*x.sim[ii,,tt-1]
				u <- PathCost(xbar,A=A,Alpha=Alpha,Beta=Beta,pow=pow)
			}
      		pr <- PathProb(u,ODpair=ODpair,A=A,RUM=RUM,theta=theta)
      		for (i in 1:N.OD){
        			indx <- (indices[i]+1):(indices[i+1])
        			x.sim[ii,indx,tt] <- rmultinom(1,ODdemand[i],pr[indx])
      		}
			u.sim[ii,,tt] <- u
		}
	}
	list(x=x.sim,u=u.sim)
}


# Assignment 3 - Example Code
#QUESTION 1
base.samp = function(p,n) {   #DEFINE FUNCTION TO SAMPLE FROM SET {0,1/(p-1),...1}
  x = (p-1-p/2) * runif(n)    #NEED TO LIMIT TO RANGE OF (0, 1-delta)
  round(x) / (p-1)
}

mymorris = function(k,r,p,delta,par.mins,par.maxs,fun) {  #NOTE THE LAST INPUT IS THE MODEL NAME FOR SENS ANALYSIS

  par.range = par.maxs - par.mins
  effects = array(dim = c(k,r))

  for (r.ind in 1:r) {
    J = array(1,dim=c(k+1,k)) #AN ARRAY OF ONES
    B = lower.tri(J) * 1    #A LOWER TRIANGULAR ARRAY OF ONES
    xstar = base.samp(p,k)    #BASE VECTOR
    D = array(0,dim=c(k,k))   #AN ARRAY WITH EITHER 1 OR -1 IN DIAGONAL
    diag(D) = 1.0 -2*(runif(k) < .5)
    P = array(0,dim=c(k,k))   #A RANDOM PERMUTATION ARRAY
    diag(P) = 1
    P = P[,sample(c(1:k),k,replace=F)]
    Bstar =  (t(xstar*t(J)) + (delta/2) * ((2*B - J)%*%D + J)) %*% P

    y = numeric(length=(k+1)) #VECTOR TO HOLD MODEL OUTPUT
    for (i in 1:(k+1)) y[i] = fun(par.mins + par.range * Bstar[i,] )
    for (i in 1:k) {
      par.change = Bstar[i+1,] - Bstar[i,]  #FIND WHICH PARAMETER CHANGED AND WHETHER UP OR DOWN
      i2 = which(par.change != 0)
      effects[i2,r.ind] = (y[i+1] - y[i]) * (1 - 2 * (par.change[i2] < 0))
    }
  }
  effects   #RETURN THE k x r ARRAY OF COMPUTED EFFECTS
}


mod1 = function(v, n)
# mod1(1:20, 6)   =>   1 2 3 4 5 6 1 2 3 4 5 6 1 2 3 4 5 6 1 2
    ((v - 1) %% n) + 1

str2ints = function(s)
    as.integer(Filter(Negate(is.na),
        factor(levels = LETTERS, strsplit(toupper(s), "")[[1]])))

vigen = function(input, key, decrypt = F)
   {input = str2ints(input)
    key = rep(str2ints(key), len = length(input)) - 1
    paste(collapse = "", LETTERS[
        mod1(input + (if (decrypt) -1 else 1)*key, length(LETTERS))])}

message(vigen("Beware the Jabberwock, my son! The jaws that bite, the claws that catch!", "vigenerecipher"))
  # WMCEEIKLGRPIFVMEUGXQPWQVIOIAVEYXUEKFKBTALVXTGAFXYEVKPAGY
message(vigen("WMCEEIKLGRPIFVMEUGXQPWQVIOIAVEYXUEKFKBTALVXTGAFXYEVKPAGY", "vigenerecipher", decrypt = T))
  # BEWARETHEJABBERWOCKMYSONTHEJAWSTHATBITETHECLAWSTHATCATCH


fft <- function(timeScopeList, M) {
    N <- 2^M
    freqScopeList <- timeScopeList[1:N]

    LH <- N/2
    J <- N/2
    if (2<=N-1) {
        for (I in seq(2, N-1, 1)) {
            if (I<J) {
                temp <- freqScopeList[I]
                freqScopeList[I] <- freqScopeList[J+1]
                freqScopeList[J+1] <- temp
            }

            K=LH
            while(J>=K) {
                J=J-K
                K=K/2
            }
            J=J+K
        }
    }

    for (L in seq(1, M, 1)) {
        B <- 2^(L-1)
        for (J in seq(0, B-1, 1)) {
            P <- J*(2^(M-L))
            WNP <- exp(-1i * 2 * pi * P / N)
            for (k in seq(J, N-1, 2^L)) {
                temp <- freqScopeList[k+1]+freqScopeList[k+B+1]*WNP
                freqScopeList[k+B+1] <- freqScopeList[k+1]-freqScopeList[k+B+1]*WNP
                freqScopeList[k+1] <- temp
            }
        }
    }

    return(freqScopeList)
}

print(fft(c(1, 2, 3, 4, 5, 6, 7, 8), 3))


=begin
[((<index-ja|URL:index-ja.html>))]

= 練習帖

== CONTENTS
* ((<有限集合>))
  * ((<集合>))
  * ((<写像>))
  * ((<群>))
* ((<多項式の計算>))
* ((<多変数多項式の計算>))
* ((<多変数多項式の計算その２>))
* ((<多項式を複数の多項式で割った余りを求める>))
* ((<多項式のグレブナ基底を求める>))
* ((<素体を作る>))
* ((<代数体を作る>))
* ((<商体の生成>))
  * ((<整数環の商体を取って有理数を作る>))
  * ((<有理関数体の生成>))
  * ((<代数拡大体上の有理式の計算>))
  * ((<代数関数体>))
* ((<線形代数>))
  * ((<連立1次方程式を解く>))
  * ((<正方行列の対角化>))
  * ((<行列の単因子を求める>))
  * ((<行列の Jordan 標準形を求める>))
  * ((<Cayley-Hamilton の定理の（次元毎の）証明>))
* ((<グレブナ基底を元の基底で表現する>))
* ((<任意の基底で割った商と余りを求める（余り＝０に意味がある）>))
* ((<因数分解>))
  * ((<整数係数多項式の因数分解>))
  * ((<Zp 係数多項式の因数分解>))
  * ((<有理数の代数拡大上の多項式の因数分解>))
  * ((<有理数の代数拡大の代数拡大上の多項式の因数分解>))
  * ((<x^4 + 10x^2 + 1 の因数分解>))
  * ((<整数、有理係数多変数多項式の因数分解>))
  * ((<Zp 係数多変数多項式の因数分解>))
* ((<代数方程式>))
  * ((<最小多項式>))
  * ((<最小分解体>))
  * ((<多項式のガロア群>))
* ((<初等幾何>))
  * ((<重心の存在>))
  * ((<外心の存在>))
  * ((<垂心の存在>))
  * ((<4 つの等面積>))
* ((<解析>))
  * ((<ラグランジュの乗数法>))

== 有限集合

=== 集合

<<< sample-set01.rb.v.rd

=== 写像

<<< sample-map01.rb.v.rd

=== 群

<<< sample-group01.rb.v.rd

== 多項式の計算

<<< sample-polynomial01.rb.v.rd

== 多変数多項式の計算

<<< sample-polynomial02.rb.v.rd

== 多変数多項式の計算その２

<<< sample-m-polynomial01.rb.v.rd

== 多項式を複数の多項式で割った余りを求める

<<< sample-divmod01.rb.v.rd

== 多項式のグレブナ基底を求める

<<< sample-groebner01.rb.v.rd

== 素体を作る

<<< sample-primefield01.rb.v.rd

== 代数体を作る

<<< sample-algebraicfield01.rb.v.rd

=== これと同じものが次の様に書ける。

<<< sample-algebraicfield02.rb.v.rd

=== ルートの計算

<<< sample-algebraic-root01.rb.v.rd

== 商体の生成

=== 整数環の商体を取って有理数を作る

<<< sample-quotientfield01.rb.v.rd

=== 有理関数体の生成

<<< sample-quotientfield02.rb.v.rd

=== 代数拡大体上の有理式の計算

<<< sample-quotientfield03.rb.v.rd

=== 代数関数体

<<< sample-quotientfield04.rb.v.rd

== 線形代数

=== 連立1次方程式を解く

<<< sample-gaussian-elimination01.rb.v.rd

=== 正方行列の対角化

<<< sample-diagonalization01.rb.v.rd >>>

=== 行列の単因子を求める

<<< sample-elementary-divisor01.rb.v.rd

=== 行列の Jordan 標準形を求める

<<< sample-jordan-form01.rb.v.rd

=== Cayley-Hamilton の定理の（次元毎の）証明

<<< sample-cayleyhamilton01.rb.v.rd

== グレブナ基底を元の基底で表現する

<<< sample-groebner02.rb.v.rd

== 任意の基底で割った商と余りを求める（余り＝０に意味がある）

<<< sample-groebner03.rb.v.rd

== 因数分解

=== 整数係数多項式の因数分解

<<< sample-factorize01.rb.v.rd

=== Zp 係数多項式の因数分解

<<< sample-factorize02.rb.v.rd

=== 有理数の代数拡大上の多項式の因数分解

<<< sample-factorize03.rb.v.rd

=== 有理数の代数拡大の代数拡大上の多項式の因数分解

<<< sample-factorize04.rb.v.rd

=== x^4 + 10x^2 + 1 の因数分解

<<< sample-factorize05.rb.v.rd

=== 整数、有理係数多変数多項式の因数分解

<<< sample-m-factorize01.rb.v.rd

=== Zp 係数多変数多項式の因数分解

<<< sample-m-factorize02.rb.v.rd

== 代数方程式

=== 最小多項式

<<< sample-algebraic-equation01.rb.v.rd

=== 最小分解体

<<< sample-splitting-field01.rb.v.rd

=== 多項式のガロア群

<<< sample-galois-group01.rb.v.rd

== 初等幾何

=== 重心の存在

<<< sample-geometry01.rb.v.rd

=== 外心の存在

<<< sample-geometry02.rb.v.rd

#=== 内心の存在

#<<< sample-geometry03.rb.v.rd

=== 垂心の存在

<<< sample-geometry04.rb.v.rd

=== 4 つの等面積
see ((<URL:http://www1.odn.ne.jp/drinkcat/topic/column/quest/quest_2/quest_2.html>)) Question 3.

<<< sample-geometry07.rb.v.rd

== 解析
=== ラグランジュの乗数法
<<< sample-lagrange-multiplier01.rb.v.rd

=end