# function collections

bootstrap.test.sub <- function(k1, k2) {
  # this gives a single permutation results k1 and k2 are two vectors with K's
  combined.k <- c(k1, k2)
  k.length <- length(combined.k)
  shuffled <- sample(combined.k)
  k1.b <- shuffled[1:length(k1)]
  k2.b <- shuffled[(1 + length(k1)):k.length]
  mean(abs(k1.b - k2.b))
}

bootstrap.test <- function(k1, k2, B) {
  # bootstrap test; repeats bootstrap.test.sub B times
  re <- replicate(B, bootstrap.test.sub(k1, k2))
  test.stat <- mean(abs(k1 - k2))
  p.val <- mean(test.stat <= re)
  return(p.val)
}

colmax <- function(x) {
  apply(x, 2, max, na.rm = TRUE)
}  # useful function

rqclass <- function(x, k) {
  # modified from mclust::qclass
  x <- as.vector(x)
  # eps <- sqrt(.Machine$double.eps) numerical accuracy problem if scale of x is large,
  # so make tolerance scale dependent
  eps <- sd(x) * sqrt(.Machine$double.eps)
  q <- NA
  n <- k
  while (length(q) < (k + 1)) {
    n <- n + 1
    qx <- seq(from = 0, to = 1, length = n)
    qx <- jitter(qx, amount = 0.5/n)
    qx[1] <- 0
    qx[length(qx)] <- 1
    q <- unique(quantile(x, qx))
  }
  if (length(q) > (k + 1)) {
    dq <- diff(q)
    nr <- length(q) - k - 1
    q <- q[-order(dq)[1:nr]]
  }
  q[1] <- min(x) - eps
  q[length(q)] <- max(x) + eps
  cl <- rep(0, length(x))
  for (i in 1:k) {
    cl[x >= q[i] & x < q[i + 1]] <- i
  }
  cl
}

rand.gmm <- function(x, G, model) {
  # x: the vector of the (random) coefficients G: number of component model: takes
  # value between 'E' (Equal variance) or 'V' (varying variance)

  zz <- mclust::unmap(rqclass(x, G))  # random assignment with jittering from the equal partition
  delta <- 1000
  ms <- mclust::mstep(modelName = model, data = x, z = zz)
  old.param <- ms$paraneters$mean  # random initial guess for mean
  flag <- TRUE
  while (delta > 1e-05 & flag) {
    # EM step

    flag <- sum(is.na(ms$parameters$mean)) == 0
    es <- mclust::estep(modelName = model, data = x, z = zz, parameters = ms$parameters)
    zz <- es$z
    ms <- mclust::mstep(modelName = model, data = x, z = zz)
    new.param <- ms$parameters$mean
    delta <- sum(abs(old.param - new.param))
    old.param <- ms$parameters$mean

  }
  if (flag) {
    ZZ <- ms$z
    Ms <- ms$parameters$mean
    S <- sqrt(ms$parameters$variance$sigmasq)
    p <- ms$parameters$pro

    # for matrix calculation
    X <- matrix(rep(x, length(Ms)), nrow = length(x))
    MM <- matrix(rep(Ms, each = length(x)), nrow = length(x))
    PP <- matrix(rep(p, each = length(x)), nrow = length(x))

    # distinction between E and V get loglikelihood
    if (!(model %in% c("E", "V"))) {
      stop("model must be either E or V")
    }
    if (model == "E") {
      SS <- matrix(rep(S, length(Ms) * length(x)), nrow = length(x))
    }
    if (model == "V") {
      SS <- matrix(rep(S, each = length(x)), nrow = length(x))
    }

    loglik <- sum(log(rowSums(dnorm(X, MM, SS) * PP)))
    b <- bic(modelName = model, loglik = loglik, n = length(x), d = 1, G = G, equalPro = FALSE)
  } else {
    b <- NA
  }
  return(b)
}

EV.rep <- function(x, M = 100, G) {
  # internal function used in K.out
  r1 <- replicate(M, rand.gmm(x, G, "V"))
  r2 <- replicate(M, rand.gmm(x, G, "E"))
  V <- max(r1, na.rm = TRUE)
  E <- max(r2, na.rm = TRUE)
  out <- c(E, V, G)
  names(out) <- c("E", "V", "G")
  return(out)
}

K.out <- function(x, M = 100, g.max = 9) {
  evout <- list()
  for (g in 1:g.max) {
    evout[[g]] <- EV.rep(x, 200, g)
  }
  sum.out <- do.call("rbind", evout)
  sum.out <- data.frame(sum.out)
  G <- which(sum.out == max(sum.out[, c("E", "V")]), arr.ind = TRUE)[1]
  md <- c("E", "V")[which(sum.out == max(sum.out[, c("E", "V")]), arr.ind = TRUE)[2]]
  return(list(G = G, model = md))
}


### title: "Create report performing EDA rendered as Rmarkdown html document with DataExplorer package"###

# Clear workspace and memory
rm(list = ls()); gc(reset = TRUE)

setwd('C:\\Users\\Desktop\\WORKING\\EDA') # change this path to your working directory #

# load dataset

data(iris)
load(iris)
set.seed(250)

#Let us begin our Exploratory Data Analysis by loading the library:
library(DataExplorer)

# Variables
# The very first thing that you'd want to do in your EDA is checking the dimension of the input dataset.
plot_str(iris)

# Looking for Missing Values
plot_missing(iris)

# Histogram of Continuous Variables
plot_histogram(iris)

# Density plot
plot_density(iris)

# Colorful Correlation Plot
plot_correlation(iris, type = 'all','Species')

# plot Categorical Variables - Barplots!
plot_bar(iris)

# Finally,create consolidated report with create_report()
create_report(iris) #comment this if you're not rendering this entire rmarkdown


function (tmp1)
{
	#Establish plot frame
    plot(120, 1, type = "n", xlim = c(120, 180),
		ylim = c(1, 4), yaxt = "n", ylab = "", xlab = "Shape")

	#Confidence interval for initial boundary in left group
		rect(tmp1[11, 3] - (tmp1[11, 6]) * qt(0.975, tmp1[11, 4]),
        0, tmp1[11, 3] + (tmp1[11, 6]) * qt(0.975, tmp1[11, 4]),
        6, col = hsv(1, 0.2, 1), border = NA)

	#Confidence interval for initial boundary in right group
		rect(tmp1[12, 3] - (tmp1[12, 6]) * qt(0.975, tmp1[12, 4]),
        0, tmp1[12, 3] + (tmp1[12, 6]) * qt(0.975, tmp1[12, 4]),
        6, col = hsv(1/3, 0.2, 1), border = NA)

	#Plot boundary
	box()

	#Add t2 boundary for each group and condition
    points(tmp1$boundary[3:10], c(4, 4, 3, 3, 2, 2, 1, 1), pch = 16,
        cex = 2, col = c(2, 3, 2, 3, 2, 3, 2, 3, 2, 3))

	#Y axis labels
	mtext(side = 2, at = c(4, 3, 2, 1), text = c("Close", "Dead",
        "Mid", "Far"), adj = 1, srt = 2)

    abline(v = 150, lty = 2) #midpoint dashed line
    abline(v = tmp1$boundary[11], col = 2, lwd = 2) #
    abline(v = tmp1$boundary[12], col = 3, lwd = 2)
    lines(tmp1$boundary[c(3, 5, 7, 9)], c(4, 3, 2, 1), lwd = 2,
        col = 2)
    lines(tmp1$boundary[c(4, 6, 8, 10)], c(4, 3, 2, 1), lwd = 2,
        col = 3)
    arrows(tmp1$boundary[3:10], c(4, 4, 3, 3, 2, 2, 1, 1), tmp1$boundary[3:10] +
        tmp1$SErr[3:10], c(4, 4, 3, 3, 2, 2, 1, 1), col = c(2,
        3, 2, 3, 2, 3, 2, 3), angle = 90, length = 0.1)
    arrows(tmp1$boundary[3:10], c(4, 4, 3, 3, 2, 2, 1, 1), tmp1$boundary[3:10] -
        tmp1$SErr[3:10], c(4, 4, 3, 3, 2, 2, 1, 1), col = c(2,
        3, 2, 3, 2, 3, 2, 3), angle = 90, length = 0.1)
}


[[[[[
   Lemma for
      H(y|x) <= H(x,y) - H(x) + c

   We show that
      H(x) <= -log_2 Sum_y P((x y)) + c

   Proof: From U construct U' such that
      if U(p) = (x y), then U'(p) = x.

   Then apply the previous chapter to get
      H(x) <= -log_2 P'(x) + c
           <= -log_2 Sum_y P((x y)) + c
]]]]]

define U-prime

let (is-pair? x)
   if atom x         false
   if atom cdr x     false
   if atom cdr cdr x true
                     false

[run original program for U]

let v eval read-exp

[and if is a pair, return first element]

if (is-pair? v) car v

[otherwise loop forever]

   let (loop) [be] (loop) [in]
      (loop)

define      U-prime
value       ((' (lambda (is-pair?) ((' (lambda (v) (if (is-pai
            r? v) (car v) ((' (lambda (loop) (loop))) (' (lamb
            da () (loop))))))) (eval (read-exp))))) (' (lambda
             (x) (if (atom x) false (if (atom (cdr x)) false (
            if (atom (cdr (cdr x))) true false))))))

[Test it!]

run-utm-on bits' xyz

expression  (car (cdr (try no-time-limit (' (eval (read-exp)))
             (bits (' xyz)))))
value       xyz

run-utm-on bits' cons a nil

expression  (car (cdr (try no-time-limit (' (eval (read-exp)))
             (bits (' (cons a nil))))))
value       (a)

run-utm-on bits' cons a cons b nil

expression  (car (cdr (try no-time-limit (' (eval (read-exp)))
             (bits (' (cons a (cons b nil)))))))
value       (a b)

run-utm-on bits' cons a cons b cons c nil

expression  (car (cdr (try no-time-limit (' (eval (read-exp)))
             (bits (' (cons a (cons b (cons c nil))))))))
value       (a b c)

cadr try 99 U-prime bits' xyz

expression  (car (cdr (try 99 U-prime (bits (' xyz)))))
value       out-of-time

cadr try 99 U-prime bits' cons a nil

expression  (car (cdr (try 99 U-prime (bits (' (cons a nil))))
            ))
value       out-of-time

cadr try 99 U-prime bits' cons a cons b nil

expression  (car (cdr (try 99 U-prime (bits (' (cons a (cons b
             nil)))))))
value       a

cadr try 99 U-prime bits' cons a cons b cons c nil

expression  (car (cdr (try 99 U-prime (bits (' (cons a (cons b
             (cons c nil))))))))
value       out-of-time


library(tidyverse)

# read in data
msa <- read.csv("msapop.csv")
# create new data to conform with Gabaix (1999)
msa135 <- msa %>%
  filter(rank2010<=135)

# plot -- all MSAs
p <- ggplot(msa)+
  aes(x = log(pop2010), y = log(rank2010))+
  geom_point(alpha = 0.5, size = 2, color = "#E69F00") +
  geom_smooth(method = "lm", se = FALSE, size=0.5, color="#2b2b2b", alpha=0.5) +
  # Theming
  labs(
    title="Zipf's law",
    subtitle="Log population and log population rank, All U.S. metropolitan areas, 2010",
    caption="Author: Chris Goodman (@cbgoodman), Data: U.S. Census Bureau & Author's calculations.",
    y="Log of Rank",
    x="Log of Population") +
  theme_minimal(base_family="Open Sans Condensed Light") +
  # light, dotted major y-grid lines only
  theme(panel.grid=element_line())+
  theme(panel.grid.major.y=element_line(color="#2b2b2b", linetype="dotted", size=0.15))+
  theme(panel.grid.major.x=element_blank())+
  theme(panel.grid.minor.x=element_blank())+
  theme(panel.grid.minor.y=element_blank())+
  # light x-axis line only
  theme(axis.line=element_line())+
  theme(axis.line.y=element_blank())+
  theme(axis.line.x=element_blank())+
  # tick styling
  theme(axis.ticks=element_line())+
  theme(axis.ticks.x=element_blank())+
  theme(axis.ticks.y=element_blank())+
  theme(axis.ticks.length=unit(5, "pt"))+
  # x-axis labels
  theme(axis.text.x=element_text(size=10, hjust=0.95,vjust=0.2))+
  # breathing room for the plot
  theme(plot.margin=unit(rep(0.5, 4), "cm"))+
  # move the y-axis tick labels over a bit
  theme(axis.text.y=element_text(margin=margin(r=-5)))+
  theme(axis.text.x=element_text(margin=margin(r=-5)))+
  # make the plot title bold and modify the bottom margin a bit
  theme(plot.title=element_text(family="Open Sans Condensed Bold", margin=margin(b=15)))+
  # make the subtitle italic
  theme(plot.subtitle=element_text(family="Open Sans Condensed Light Italic"))+
  theme(plot.caption=element_text(size=8, hjust=0, margin=margin(t=15)))
ggsave(plot=p, "zipf.png", width=8, height=6, units="in", dpi="retina")

summary(lm(data=msa, log(rank2010)~log(pop2010)))

# plot -- 135 largest
p1 <- ggplot(msa135) +
  aes(x = log(pop2010), y = log(rank2010)) +
  # points
  geom_point(alpha = 0.5, size = 2, color = "#E69F00") +
  # point labels for the largest cities -- still deciding
  # geom_text(aes(label=ifelse(rank2010<5,as.character(msa),'')),hjust=0,vjust=0) +
  # trend line
  geom_smooth(method = "lm", se = FALSE, size=0.5, color="#2b2b2b", alpha=0.5) +
  # theming
  labs(
    title="Zipf's law",
    subtitle="Log population and log population rank, 135 largest U.S. metropolitan areas, 2010",
    caption="Author: Chris Goodman (@cbgoodman), Data: U.S. Census Bureau & Author's calculations.",
    y="Log of Rank",
    x="Log of Population") +
  theme_minimal(base_family="Open Sans Condensed Light") +
  # light, dotted major y-grid lines only
  theme(panel.grid=element_line())+
  theme(panel.grid.major.y=element_line(color="#2b2b2b", linetype="dotted", size=0.15))+
  theme(panel.grid.major.x=element_blank())+
  theme(panel.grid.minor.x=element_blank())+
  theme(panel.grid.minor.y=element_blank())+
  # light x-axis line only
  theme(axis.line=element_line())+
  theme(axis.line.y=element_blank())+
  theme(axis.line.x=element_blank())+
  # tick styling
  theme(axis.ticks=element_line())+
  theme(axis.ticks.x=element_blank())+
  theme(axis.ticks.y=element_blank())+
  theme(axis.ticks.length=unit(5, "pt"))+
  # x-axis labels
  theme(axis.text.x=element_text(size=10, hjust=0.95,vjust=0.2))+
  # breathing room for the plot
  theme(plot.margin=unit(rep(0.5, 4), "cm"))+
  # move the xy-axis tick labels over a bit
  theme(axis.text.y=element_text(margin=margin(r=-5)))+
  theme(axis.text.x=element_text(margin=margin(r=-5)))+
  # make the plot title bold and modify the bottom margin a bit
  theme(plot.title=element_text(family="Open Sans Condensed Bold", margin=margin(b=15)))+
  # make the subtitle italic
  theme(plot.subtitle=element_text(family="Open Sans Condensed Light Italic"))+
  theme(plot.caption=element_text(size=8, hjust=0, margin=margin(t=15)))
ggsave(plot=p1, "zipf135.png", width=8, height=6, units="in", dpi="retina")

summary(lm(data=msa135, log(rank2010)~log(pop2010)))


bubblesort <- function(v) {
  itemCount <- length(v)
  repeat {
    hasChanged <- FALSE
    itemCount <- itemCount - 1
    for(i in 1:itemCount) {
      if ( v[i] > v[i+1] ) {
        t <- v[i]
        v[i] <- v[i+1]
        v[i+1] <- t
        hasChanged <- TRUE
      }
    }
    if ( !hasChanged ) break;
  }
  v
}

v <- c(9,8,7,3,1,100)
print(bubblesort(v))


hist(rnorm(10000), col = "red")


#' Generate synthetic vectors from their sampling distributions
#'
#' One way of creating synthetic data is replicating sampling distribution
#' of the variable. This function can be applied to dataframes, numeric or
#' character/factor vectors and obtain an object of equal length with synthetic values.
#'
#' @param obj A dataframe, numeric vector or character/factor vector.
#' @param seed Specify seed when replication is desired.
#' @param n_news Length of the new vectors. By default, same length as input.
#'
#' @return
#' An object of equal dimensions (if `n_news` is not specified) with synthetic values.
#'
#' @export
#'
#' @examples
#' generate_synthetic_object(mtcars)
#'
#' generate_synthetic_object(mtcars$mpg)
#'
#' generate_synthetic_object(as.factor(mtcars$cyl))

generate_synthetic_object <- function(obj, seed = NULL, n_news = NULL){
    UseMethod('generate_synthetic_object')
}

#' @rdname generate_synthetic_object
#' @export

generate_synthetic_object.default <- function(obj, seed = NULL, n_news = NULL ){
    # for character and factor vectors
    if(is.null(n_news)) n_news <- length(obj)

    set.seed(seed)
    new_values <- sample( obj, n_news, TRUE )

    if( is.factor(obj) ){
        new_values <- factor(new_values, levels = levels(obj) )
    }

    return(new_values)
}

#' @rdname generate_synthetic_object
#' @export

generate_synthetic_object.numeric <- function(obj, seed = NULL, n_news = NULL){

    if(is.null(n_news)) n_news <- length(obj)

    set.seed(seed)
    ind <- sample(obj,size = round(0.1*length(obj)))
    n_decimals <- max(decimalplaces(ind))

    dd <- density(obj, from = min(obj), to = max(obj))

    set.seed(seed)
    new_values <- approx(x = cumsum(dd$y)/sum(dd$y),
                         y = dd$x,
                         xout = runif(n_news))$y
    new_values <- round( new_values, n_decimals )

    return(new_values)
}

#' @rdname generate_synthetic_object
#' @export
generate_synthetic_object.data.frame <- function(obj, seed = NULL, n_news = NULL){
    synthetic_obj <- vector('list', ncol(obj))
    names(synthetic_obj) <- names(obj)

    for (i in seq_len(ncol(obj))) {

        var_temp <- obj[[i]]

        synthetic_obj[[i]] <- generate_synthetic_object( obj = var_temp, seed = seed )

    }
    synthetic_obj <- dplyr::bind_cols(synthetic_obj)

    return(synthetic_obj)
}


\name{psm_analysis}
\alias{psm_analysis}

\title{
Van Westendorp Price Sensitivity Meter Analysis (PSM)
}

\description{
\code{psm_analysis()} performs an analysis of consumer price
  preferences and price sensitivity known as \bold{van
  Westendorp Price Sensitivity Meter (PSM)}. It takes respondent's
  price preferences (from survey data) as an input and estimates
  acceptable price ranges and price points. For a description of
  the method see the \emph{Details} section.
}

\usage{
psm_analysis(
  toocheap, cheap, expensive, tooexpensive,
  data = NA,
  validate = TRUE,
  interpolate = FALSE,
  interpolation_steps = 0.01,
  intersection_method = "min",
  pi_cheap = NA, pi_expensive = NA,
  pi_scale = 5:1,
  pi_calibrated = c(0.7, 0.5, 0.3, 0.1, 0))
}

\arguments{
  \item{toocheap, cheap, expensive, tooexpensive}{If a
  data.frame/matrix is provided in the \code{data} argument:
  names of the variables in the data.frame/matrix that contain
  the survey data on the respondents' "too cheap", "cheap",
  "expensive" and "too expensive" price preferences.

  If no data.frame/matrix is provided in the \code{data}
  argument: numeric vectors that directly include this
  information. If numeric vectors are provided, it is assumed
  that they are sorted by respondent ID (the preferences for
  respondent \code{n} are stored at the \code{n}-th position in
  all vectors).

  If the \code{toocheap} price was not assessed, a
  variable/vector of NAs can be used instead. This
  variable/vector needs to have the same length as the other
  survey information. If \code{toocheap} is NA for all cases,
  it is possible to calculate the Point of Marginal
  Expensiveness and the Indifference Price Point, but it is
  impossible to calculate the Point of Marginal Cheapness and
  the Optimal Price Point.}
  \item{data}{data.frame or matrix that contains the function's
  input data. \code{data} input is not mandatory: Instead of
  using one data.frame/matrix as an input, it is also possible
  to provide the data directly as vectors in the "too cheap",
  "cheap", "expensive" and "too expensive" arguments.}
  \item{validate}{logical. should only respondents with
  consistent price preferences (too cheap < cheap < expensive
  < too expensive) be considered in the analysis?}
  \item{interpolate}{logical. should interpolation of the price
  curves be applied between the actual prices given by the
  respondents? If interpolation is enabled, the output appears
  less bumpy in regions with sparse price information. If the
  sample size is sufficiently large, interpolation should not
  be necessary.}
  \item{interpolation_steps}{numeric. if \code{interpolate} is
  \code{TRUE}: the size of the interpolation steps. Set by
  default to 0.01, which should be appropriate for most goods
  in a price range of 0-50 USD/Euro.}
  \item{intersection_method}{"min" (default), "max", "mean" or
  "median". defines the method how to determine the price
  points (range, indifference price, optimal price) if there
  are multiple possible intersections of the price curves.
  "min" uses the lowest possible prices, "max" uses the
  highest possible prices, "mean" calculates the mean among
  all intersections and "median" uses the median of all
  possible intersections}
  \item{pi_cheap, pi_expensive}{Only required for the Newton
  Miller Smith extension. If \code{data} argument is provided:
  names of the variables in the data.frame/matrix that contain
  the survey data on the respondents' purchase intent at their
  individual cheap/expensive price.}
  \item{pi_scale}{Only required for the Newton Miller Smith
  extension. Scale of the purchase intent variables pi_cheap and
  pi_expensive. By default assuming a five-point scale with 5
  indicating the highest purchase intent.}
  \item{pi_calibrated}{Only required for the Newton Miller Smith
  extension. Calibrated purchase probabilities that are assumed
  for each value of the purchase intent scale. Must be the same
  order as the pi_scale variable so that the first value of
  pi_calibrated corresponds to the first value in the pi_scale
  variable. Default values are taken from the Sawtooth Software
  PSM implementation in Excel: 70\% for the best value of the
  purchase intent scale, 50\% for the second best value,
  30\% for the third best value (middle of the scale), 10\%
  for the fourth best value and 0\% for the worst value.}
}

\details{
The Price Sensitivity Meter method for the analysis of consumer
price preferences was proposed by the Dutch economist Peter van
Westendorp in 1976 at the ESOMAR conference. It is a
survey-based approach that has become one of the standard price
acceptance measurement techniques in the market research
industry and is still widely used for during early-stage product
development.

Price acceptance and price sensitivity are measured in van
Westendorp's approach by four open-ended survey questions:

\itemize{
\item At which price on this scale are you beginning to
experience \dots (test-product) as cheap?
\item At which price on this scale are you beginning to
experience \dots (test-product) as expensive?
\item At which price on this scale you are beginning to
experience \dots (test-product) as too expensive -- so that you
would never consider buying it yourself?
\item At which price on this scale you are beginning to
experience \dots (test-product) as too cheap -- so that you say
"at this price the quality cannot be good"?
}

Respondents with inconsistent price preferences (e.g. "cheap"
price larger than "expensive" price) are usually removed from
the data set. This function has built-in checks to detect
invalid preference structures and removes those respondents from
the analysis by default.

To analyze price preferences and price sensitivity, the method
uses cumulative distribution functions for each of the
aforementioned price steps (e.g. "how many respondents think
that a price of \code{x} \emph{or more} is expensive?"). By
convention, the distributions for the "too cheap" and the
"cheap" price are inverted. This leads to the interpretation
"how many respondents think that a price of \emph{up to}
\code{x} is (too) cheap?".

The interpretation is built on the analysis of the intersections
of the four cumulative distribution functions for the different
prices (usually via graphical inspection). The original paper
describes the four intersections as follows:

\itemize{
\item \bold{Point of Marginal Cheapness (MGP)}: Below this price
point, there are more respondents that consider the price as
"too cheap" than respondents who consider it as "not cheap"
(intersection of "too cheap" and "not cheap"). This is interpreted
as the lower limit of the range of acceptable prices.
\item \bold{Point of Marginal Expensiveness (MEP)}. Above this
price point, there are more respondent that consider the price
as "too expensive" than there are respondents who consider it as
"not expensive" (intersection of "not expensive" and "too
expensive"). This is interpreted as the upper limit of the
range of acceptable prices.
\item \bold{Indifference Price Point (IDP)}: The same number of
respondents perceives the price as "cheap" and "expensive"
(intersection of "cheap" and "expensive"). In van Westendorp's
interpretation, this is either the median price paid in the
market or the price of an important market-leader.
\item \bold{Optimal Price Point (OPP)}: The same number of
respondents perceives the product as "too cheap" and "too
expensive" (intersection of "too cheap" and "too expensive").
van Westendorp argues that this is the value for which the
respondents' resistance against the price is particularly low.
}

Besides those four intersections, van Westendorp's article
advises to analyze the cumulative distribution functions for
steep areas which indicate price steps.

To analyze trial rates and estimate revenue forecasts,
Newton/Miller/Smith have extended van Westendorp's original
model by adding two purchase intent questions that are asked for
the respondent's "cheap" and "expensive" price. The purchase
probability at the respondent's "too cheap" and "too expensive"
price are defined as \code{0}. The main logic is that the "too
expensive" price point is prohibitively expensive for the
respondent and a price at the "too cheap" price level raises
doubts about the product quality.

By combining the standard van Westendorp questions with those
two additional purchase intent questions, it becomes possible to
summarize the purchase probabilities across respondents (using
linear interpolation for the purchase probabilities between each
respondent's cornerstone prices). The maximum of this curve is
then defined as the price point with the highest expected trial
rate. Moreover, by multiplying the trial rate with the price, it
also becomes possible to estimate a price with the highest
expected revenue.

It has to be noted that the van Westendorp Price Sensitivity
Meter is useful in some cases, but does not answer every
pricing-related question. It may be a good tool to assess very
broadly if the consumers' price perceptions exceed the actual
production costs. For more complex analyses (e.g. defining
specific prices for different products to avoid cannibalization
and drive at the same time incremental growth), other
methodological approaches are needed.
}

\value{
The function output consists of the following elements:

    \item{\code{data_input}:}{\code{data.frame} object. Contains
    the data that was used as an input for the analysis.}
    \item{\code{validated}:}{\code{logical} object. Indicates
    whether the \code{"validate"} option has been used (to
    exclude cases with intransitive price preferences).}
    \item{\code{invalid_cases}:}{\code{numeric} object. Number
    of cases with intransitive price preferences.}
    \item{\code{total_sample}:}{\code{"numeric"} object.
    Total sample size of the input sample \emph{before}
    assessing the transitivity of individual price preferences.}
    \item{\code{data_vanwestendorp}:}{\code{data.frame} object.
    Output data of the Price Sensitivity Meter analysis.
    Contains the cumulative distribution functions for the four
    price assessments (too cheap, cheap, expensive, too
    expensive) for all prices.}
    \item{\code{pricerange_lower}:}{\code{numeric} object. Lower
    limit of the acceptable price range as defined by the
    Price Sensitivity Meter, also known as \bold{point of
    marginal cheapness}: Intersection of the "too cheap" and the
    "not cheap" curves.}
    \item{\code{pricerange_upper}:}{\code{numeric} object. Upper
    limit of the acceptable price range as defined by the Price
    Sensitivity Meter, also known as \bold{point of marginal
    expensiveness}: Intersection of the "too expensive" and the
    "not expensive" curves.}
    \item{\code{idp}:}{\code{numeric} object. \bold{Indifference
    Price Point} as defined by the Price Sensitivity Meter:
    Intersection of the "cheap" and the "expensive" curves.}
    \item{\code{opp}:}{\code{numeric} object. \bold{Optimal
    Price Point} as defined by the Price Sensitivity Meter:
    Intersection of the "too cheap" and the "too expensive"
    curves.}
    \item{\code{NMS}:}{\code{logical} object. Indicates whether
    the additional analyses of the Newton Miller Smith Extension
    were performed.}
    \item{\code{weighted}:}{\code{logical} object. Indicates
    if weighted data was used in the analysis. Outputs from
    \code{psm_analysis()} always have the value \code{FALSE}.
    When data is weighted, use the function
    \code{\link{psm_analysis_weighted}.}}
    \item{\code{data_nms}:}{\code{data.frame} object. Output of
    the Newton Miller Smith extension: calibrated mean
    purchase probabilities for each price point.}
    \item{\code{pi_scale}:}{\code{data.frame} object. Shows the
    values of the purchase intent variable and the
    corresponding calibrated purchase probabilities as defined
    in the function input for the Newton Miller Smith
    extension.}
    \item{\code{price_optimal_trial}:}{\code{numeric} object.
    Output of the Newton Miller Smith extension: Estimate for
    the price with the highest trial rate.}
    \item{\code{price_optimal_revenue}:}{\code{numeric} object.
    Output of the Newton Miller Smith extension:
    Estimate for the price with the highest revenue (based on
    the trial rate).}
}

\references{
  Van Westendorp, P (1976) "NSS-Price Sensitivity Meter (PSM) --
  A new approach to study consumer perception of price"
  \emph{Proceedings of the ESOMAR 29th Congress}, 139--167. Online
  available at \url{https://www.researchworld.com/a-new-approach-to-study-consumer-perception-of-price/}.

  Newton, D, Miller, J, Smith, P, (1993) "A market acceptance
  extension to traditional price sensitivity measurement"
  \emph{Proceedings of the American Marketing Association
  Advanced Research Techniques Forum}.

  Sawtooth Software (2016) "Templates for van Westendorp PSM for
  Lighthouse Studio and Excel". Online available at
  \url{https://sawtoothsoftware.com/resources/software-downloads/tools/van-westendorp-price-sensitivity-meter}
}

\seealso{
The function \code{psm_analysis_weighted()} performs the same
analyses for weighted data.
}

\examples{

set.seed(42)

# standard van Westendorp Price Sensitivity Meter Analysis
# input directly via vectors

tch <- round(rnorm(n = 250, mean = 5, sd = 0.5), digits = 2)
ch <- round(rnorm(n = 250, mean = 8.5, sd = 0.5), digits = 2)
ex <- round(rnorm(n = 250, mean = 13, sd = 0.75), digits = 2)
tex <- round(rnorm(n = 250, mean = 17, sd = 1), digits = 2)

output_psm_demo1 <- psm_analysis(toocheap = tch,
  cheap = ch,
  expensive = ex,
  tooexpensive = tex)

# additional analysis with Newton Miller Smith Extension
# input via data.frame

pint_ch <- sample(x = c(1:5), size = length(tex),
  replace = TRUE, prob = c(0.1, 0.1, 0.2, 0.3, 0.3))

pint_ex <- sample(x = c(1:5), size = length(tex),
  replace = TRUE, prob = c(0.3, 0.3, 0.2, 0.1, 0.1))

data_psm_demo <- data.frame(tch, ch, ex, tex, pint_ch, pint_ex)

output_psm_demo2 <- psm_analysis(toocheap = "tch",
  cheap = "ch",
  expensive = "ex",
  tooexpensive = "tex",
  pi_cheap = "pint_ch",
  pi_expensive = "pint_ex",
  data = data_psm_demo)

summary(output_psm_demo2)
}


# a3usingdata

# Before you get started, set your working directory using the Session menu

###################### DataFrame Manipulation (20 POINTS) ######################

# Create a vector `first_names` with 5 names in it
first_names <- c("Alex", "Bob", "Chris", "Doug", "Eddie")

# Create a vector `math_grades` with 5 hypothetical grades (0 - 100)
# in a math course (that correspond to the 5 names above)
math_grades <- c(1, 20, 50, 80, 95)

# Create a vector `spanish_grades` with 5 hypothetical grades (0 - 100)
# in a Spanish course (that correspond to the 5 names above
spanish_grades <- c(95, 80, 50, 20, 1)
# Create a data.frame variable `students` by combining
# the vectors `first_names`, `math_grades`, and `spanish_grades`
students <- data.frame(first_names, math_grades, spanish_grades,
  stringsAsFactors = F
)

# Create a variable `num_students` that contains the
# number of rows in your dataframe `students`
num_students <- nrow(students)

# Create a variable `num_courses` that contains the number of columns
# in your dataframe `students` minus one (b/c of their names)
num_courses <- ncol(students) - 1

# Add a new column `grade_diff` to your dataframe, which is equal to
# `students$math_grades` minus `students$spanish_grades`
students$grade_diff <- students$math_grades - students$spanish_grades

# Add another column `better_at_math` as a boolean (TRUE/FALSE) variable that
# indicates that a student got a better grade in math
students$better_at_math <- students$grade_diff > 0

# Create a variable `num_better_at_math` that is the number
# (i.e., one numeric value) of students better at math
num_better_at_math <- sum(students$better_at_math)

# Write your `students` dataframe to a new .csv file inside your data/ directory
# with the filename `grades.csv`. Make sure *not* to write row names.
write.csv(students, "data/grades.csv", row.names = F)

########################### Loading R Data (30 points) #########################

# In this section, you'll work with the `Titanic` data set
# Which is built into the R environment. You should be able to `View()` it
# Pay *close attention* to what each column means. Use ?Titanic to read more.

# This data set actually loads in a format called a *table*
# See https://cran.r-project.org/web/packages/data.table/data.table.pdf
# Use the `is.data.frame()` function to test if it is a table.
is.data.frame(Titanic)

# You should convert the `Titanic` variable into a data frame;
# you can use the `data.frame()` function or `as.data.frame()`
# Be sure to **not** treat strings as factors!
Titanic <- data.frame(Titanic, stringsAsFactors = F)

# Create a variable `children` that contains *only* the rows of the data frame
# with information about the children on the Titanic.
children <- Titanic[Titanic$Age == "Child", ]

# Create a variable `num_children` that is the total number of children.
# Hint: remember the `sum()` function!
num_children <- sum(children$Freq)

# Create a variable `most_lost` which has the *row* with the
# largest absolute number of losses (people who did not survive).
# Tip: if you want, you can use multiple statements (lines of code)
# if you find that helpful to create this variable.
most_lost <- max(Titanic[Titanic$Survived == "No", "Freq"])

# Define a function called `survival_rate()` that takes in a ticket class
# (e.g., "1st", "2nd") as an argument.This function should return the following
# sentence that compares the *total survival rate* of adult men vs.
# "women and children" in that ticketing class. It should read (for example):
# "Of Crew class, 87% of women and children survived and 22% of men survived.".
# The approach you take to generating the sentence to return is up to you.
# A good solution will likely utilize filtering to produce the required data.
survival_rate <- function(class_name) {
  # class subsetting
  class_set <- Titanic[Titanic$Class == class_name, ]
  adult_set <- class_set[class_set$Age == "Adult", ]
  child_set <- class_set[class_set$Age == "Child", ]
  # adult male subsetting
  adult_males <- adult_set[adult_set$Sex == "Male", ]
  surviving_males <- sum(adult_males[adult_males$Survived == "Yes", "Freq"])
  nonsurviving_males <- sum(adult_males[adult_males$Survived == "No", "Freq"])
  male_survival_rate <- surviving_males / (surviving_males + nonsurviving_males)
  # adult female and children subsetting
  adult_females <- adult_set[adult_set$Sex == "Female", ]
  surviving_females <- sum(adult_females[
    adult_females$Survived == "Yes",
    "Freq"
  ])
  nonsurviving_females <- sum(adult_females[
    adult_females$Survived == "No",
    "Freq"
  ])
  # child subsetting
  surviving_children <- sum(child_set[child_set$Survived == "Yes", "Freq"])
  nonsurviving_children <- sum(child_set[child_set$Survived == "No", "Freq"])
  # Child and Female adult combo
  surviving_woman_child <- surviving_children + surviving_females
  nonsurviving_woman_child <- nonsurviving_children + nonsurviving_females
  female_child_rate <- surviving_woman_child /
    (surviving_woman_child + nonsurviving_woman_child)

  paste("Of ", class_name, " class, ", round(female_child_rate * 100, 0),
    "% of women and children survived and ", round(male_survival_rate * 100, 0),
    "% of men survived.",
    sep = ""
  )
}

# Create variables `first_survived`, `second_survived`, `third_survived` and
# `crew_survived` by passing each class to your function above.
first_survived <- survival_rate("1st")
second_survived <- survival_rate("2nd")
third_survived <- survival_rate("3rd")
crew_survived <- survival_rate("Crew")

########################### Reading in Data (40 points)#########################
# In this section, we'll read in a .csv file with a tabular row/column layout
# This is like Microsoft Excel or Google Docs, but without the formatting.
# The .csv file we'll be working with has the life expectancy
# for each country in 1960 and 2013. We'll ask real-world questions about the
# data by writing the code that answers our question.

# Using the `read.csv` function, read the life_expectancy.csv file into
# a variable called `life_expectancy`. Makes sure not to read strings as factors
life_expectancy <- read.csv("data/life_expectancy.csv", stringsAsFactors = F)

# Determine if `life_expectancy` is a data.frame by using
# the is.data.frame function. You may also want to View() it.
is.data.frame(life_expectancy)

# Create a column `life_expectancy$change` that is the change
# in life expectancy from 1960 to 2013
life_expectancy$change <- life_expectancy$le_2013 - life_expectancy$le_1960

# Create a variable `most_improved` that is the *name* of the country
# with the largest gain in life expectancy
most_improved <- life_expectancy[life_expectancy$change ==
  max(life_expectancy$change), "country"]

# Create a variable `num_small_gain` that has the *number* of countries
# whose life expectance has improved fewer than 5 years between 1960 and 2013
num_small_gain <- sum(life_expectancy$change < 5)

# Write a function `country_change()` that takes in a country's name
# as a parameter, and returns it's change in life expectancy from 1960 to 2013
country_change <- function(country_name) {
  life_expectancy[life_expectancy$country == country_name, "change"]
}

# Using your `country_change()` function, create a variable `sweden_change`
# that is the change in life expectancy from 1960 to 2013 in Sweden
sweden_change <- country_change("Sweden")

# Define a function `lowest_life_exp_in_region()` that takes in a **region**
# as an argument, and returns the **name of the country**
# with the lowest life expectancy in 2013 (in that region)
lowest_life_exp_in_region <- function(region_name) {
  region_subset <- life_expectancy[life_expectancy$region == region_name, ]
  region_subset[ region_subset$le_2013 == min(region_subset$le_2013), "country"]
}

# Using the function you just wrote, create a variable `lowest_in_south_asia`
# that is the country with the lowest life expectancy in 2013 in South Asia
lowest_in_south_asia <- lowest_life_exp_in_region("South Asia")

# Write a function `bigger_change()` that takes in two country names
# as parameters, and returns a sentence that describes which country experienced
# a larger gain in life expectancy (and by how many years).
# For example, if you passed the values "China", and "Bolivia" to you function,
# It would return this:
# "The country with the bigger change in life expectancy was China (gain=31.9),
#  whose life expectancy grew by 7.4 years more than Bolivia's (gain=24.5)."
# Make sure to round your numbers to one digit. , digits = 1)
bigger_change <- function(country_one, country_two) {
  one_change <- round(country_change(country_one), digits = 1)
  two_change <- round(country_change(country_two), digits = 1)

  diff_change <- abs(one_change - two_change)
  if (one_change > two_change) {
    result <- paste("The country with the bigger change in life expectancy was "
      , country_one, " (gain=", one_change, ") whose life expectancy grew by "
      , diff_change, " years more than ", country_two, "'s (gain=", two_change
      , ").",
      sep = ""
    )
  } else {
    result <- paste("The country with the bigger change in life expectancy was "
      , country_two, " (gain=", two_change, ") whose life expectancy grew by "
      , diff_change, " years more than ", country_one, "'s (gain=", one_change
      , ").",
      sep = ""
    )
  }
  result
}

# Using your `bigger_change()` function, create a variable `usa_or_france`
# that describes who had a larger gain in life expectancy (the U.S. or France)
usa_or_france <- bigger_change("United States", "France")

# Write your `life_expectancy` data.frame to a new .csv file to your
# data/ directory with the filename `life_expectancy_with_change.csv`.
# Make sure not to write row names.
write.csv(students, "data/life_expectancy_with_change.csv", row.names = F)

############################## Challenge (10 points) ###########################
# Create a variable `highest_avg_change` that has the name of the region with
# the highest *average change* in life expectancy between the two time points.
# To do this, you'll need to *compute the average* change across the countries
# in each region, and then compare the averages across regions.
# Feel free to use any library of your choice, or base R functions.
# install dot packages("dplyr")
library("dplyr")
# "using aggregate function and dyplr
region_avg <- select(life_expectancy, region, change)
  region_avg %>%
  group_by(region) %>%
  summarise(mean_reg = mean(change, na.rm = TRUE))

  highest_avg_change <- max(region_avg[max(region_avg$change), "region"])

# Create a *well labeled* plot (readable title, x-axis, y-axis) showing
# Life expectancy in 1960 v.s. Change in life expectancy
# Programmatically save (i.e., with code, not using the Export button)
# your graph as a .png file in your repo
# Then, in a comment below, *provide an interpretation* of the relationship
# you observe. Feel free to use any library of your choice, or base R functions.
png('rplot.png')
plot(life_expectancy$le_1960, life_expectancy$change, main="Regional Life
     Expectancy Changes From 1960", xlab = "1960 Life Expectancy",
     ylab = "Changes of Life Expectancy", col = "#2E9FDF")
dev.off()

# The changes of life expectancy since 1960 show a negative correlation of
# shorter life spans. However there is a stronger relatiohship at higher ages
# meaning countries who have a higher life expectacy average, also have it
# more consistently than those with a lower one.


# Two between subject variables, one within
# Data from St. Lawrence et al.(1995)
# Methods8, p. 479

#  Note: In data file each subject is called a Person, and I convert that to a factor.
# In reshape, it creates a variable called "subject," but that is not what I want to use.
#  In aov the model is based on Person, not subject.

data <- read.table("http://www.uvm.edu/~dhowell/methods8/DataFiles/Tab14-7.dat", header = T)
head(data)
# Create factors
data$Condition <- factor(data$Condition)
data$Sex <- factor(data$Sex)
data$Person <- factor(data$Person)

attach(data)

#Reshape the data

dataLong <- reshape(data = data, varying = 4:7, v.names = "outcome", timevar
= "Time", idvar = "subject", ids = 1:40, direction = "long")
detach(data)
dataLong$Time <- factor(dataLong$Time)
attach(dataLong)

tapply(outcome, Sex, mean)
tapply(outcome, Condition, mean)
tapply(outcome, time, mean)
options(contrasts = c("contr.sum","contr.poly"))
model1 <- aov(outcome ~ (Condition*Sex*factor(Time)) + Error(Person/(Time)))

summary(model1)

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


db <- liv
db2 <-liv
install.packages("rpart")
options(scipen=999)
par(mfrow=c(2,2))
set.seed(1234)
head (db)
names(db)
class(db)
str(db)
table(db$STATUS)
db$STATUS=ifelse(db$STATUS=="MAU",1,0)
db$RESID=ifelse(db$RESID == "PROP",1,0)
db$FONE=ifelse(db$FONE == "SIM",1,0)
db$CARTAO=ifelse(db$CARTAO == "SIM",1,0)
db$RESTR=ifelse(db$RESTR == "SIM",1,0)
db$NAO_FICCAO=ifelse(db$NAO_FICCAO == "SIM",1,0)
db$AUTO_AJUDA=ifelse(db$AUTO_AJUDA == "SIM",1,0)
db$CATEG=ifelse(db$CATEG == "SIM",1,0)

summary(db)
summary(db$STATUS)

#Regressão logistica
summary(db$IDADE)
boxplot(db$IDADE~db$STATUS, main="idade", col=11);grid(col=2)
quantile(db$IDADE, probs = seq(0,1,.05))
hist(db$IDADE, col = 18)
boxplot(db$RESID~db$STATUS, main="Residencia", col=2);grid(col=4)
table(db$UNIFED, useNA="ifany")

library(caret)

set.seed(1234)
flag=createDataPartition(db$STATUS, p=1, list=F)
tst=db[flag,]; dim(tst)

summary(tst)
fit=glm(data = tst, STATUS~. ,family = binomial())
summary(fit)
fit2=step(fit, trace=0 ) #novo modelo
summary(fit2)
tst$pmau=predict(fit2, newdata = tst, type = "response")
head(tst$pmau)
#Questão 2A1

novo.indiv=data.frame(IDADE=30,UNIFED="RJ",RESID=1,FONE=1,INSTRU="SUP",CARTAO=1,RESTR=1, NAO_FICCAO=0,AUTO_AJUDA=1,CATEG=1)
novo.p=predict(fit2, novo.indiv, type="response");novo.p

#Questão 2A2

kk=c(0.0, 0.1,   0.5,  0.8,  1)

library(arules)
classe=discretize(tst$pmau, method = "fixed", breaks = kk)

m=table(classe, tst$STATUS, dnn = c("class","status"));m
mm=prop.table(m,1);mm
round(mm,3)

kpmau=discretize(tst$pmau, method = "frequency", breaks=10)
FF=table(kpmau, tst$STATUS,dnn = c('kpmau','status'));FF
prop.table(FF,1)

library (hmeasure)
HMeasure(tst$STATUS, tst$pmau)$metric

library(pROC)
tatu=roc(tst$STATUS, tst$pmau);tatu
plot(tatu, col=3);grid(col=2)

#Questão 2A3
pc=.4  #pmau>PC  ==> classificar como mau
KLASS=ifelse(tst$pmau>pc, "recusa","aprova")
table(KLASS, tst$STATUS, dnn=c("classificaccao", "realidade")) #matriz de classificaccao
erro40=(280+187)/3000; erro40
#reprovar o bom $500, aprovar o mau $800
custo=187*500+280*800; custo

 #Questão 2B1
novo.indiv2b1=data.frame(IDADE=30,UNIFED="RJ",RESID=0,FONE=1,INSTRU="SUP",CARTAO=1,RESTR=1, NAO_FICCAO=0,AUTO_AJUDA=1,CATEG=1)
novo.p2b1=predict(fit2, novo.indiv2b1, type="response");novo.p2b1
round(novo.p2b1,3)

library(rpart)
set.seed(1234)
aclass=rpart(data = tst,STATUS~., method="class"); aclass

#Questão 2B2

library(rpart.plot)
prp(aclass, type=5, extra=104, nn=T, fallen.leaves=T, branch.col="red", branch.lty=5, box.col=c("white","green"))
aclass
erro.estim=.2*.77833;erro.estim

#Questão 2B3

p=printcp(aclass)
plot(aclass$cptable[ ,4], type="b", col=4, pch="+")
lines(aclass$cptable[,3], type="b", pch=0, col=3)

#Questão 2B4
#2 nós, 1 split
# número entre 0.048333e 0.0205000
aclass2=prune(aclass, cp=0.03); aclass2
p=printcp(aclass2)
plot(aclass2$cptable[ ,4], type="b", col=4, pch="+")
lines(aclass2$cptable[,3], type="b", pch=0, col=3)
erro.estim=.2*.77833;erro.estim

pred.aclass2=predict(aclass2, newdata=tst, type = "prob")
head(pred.aclass2, 10)
tst$pmau=pred.aclass2[,2]

#Questão 2C1
set.seed(1234)

#Questão 2C2

#Questão 2C3


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

ompthreads = function()
{
  threads = as.numeric(Sys.getenv("OMP_NUM_THREADS"))
  if (is.na(threads))
    0L
  else
    threads
}

m = 2500
n = 2500
x = matrix(runif(m*n), m, n)

barrier()
t_double = comm.timer(out_double <- qr_reduce(x))
barrier()
t_float = comm.timer(out_float <- qr_reduce(x, type="float"))

size = comm.size()
mpi_cat("method,m,n,size,threads,t_dbl_min,t_dbl_mean,t_dbl_max,t_flt_min,t_flt_mean,t_flt_max\n", quiet=TRUE)
data = paste(
  "reduce", m*size, n, size, ompthreads(),
  t_double[["min"]], t_double[["mean"]], t_double[["max"]],
  t_float[["min"]], t_float[["mean"]], t_float[["max"]],
  sep=","
)
mpi_cat(data, quiet=TRUE)
mpi_cat("\n", quiet=TRUE)

finalize()


\name{print.PAFit_result}
\alias{print.PAFit_result}
%- Also NEED an '\alias' for EACH other topic documented here.
\title{
  printing information on the estimation result stored in a \code{PAFit_result} object
}
\description{
  This function outputs simple information of the estimation result stored in a \code{PAFit_result} object. This object is stored in the field \code{$estimate_result} of a \code{Full_PAFit_result} object, which in turn is the returning value of \code{\link{only_A_estimate}}, \code{\link{only_F_estimate}} or \code{\link{joint_estimate}}.
}
\usage{
  \method{print}{PAFit_result}(x,...)
}
%- maybe also 'usage' for other objects documented here.
\arguments{
  \item{x}{
    An object of class \code{PAFit_result}.
  }

  \item{\dots}{
    %%     ~~Describe \code{\dots} here~~
  }
}

\value{
  Outputs summary information on the estimation result.
}
\author{
  Thong Pham \email{thongpham@thongpham.net}
}
\examples{
  ## Since the runtime is long, we do not let this example run on CRAN
  \dontrun{
    library("PAFit")
    set.seed(1)
    # a network from Bianconi-Barabasi model
    net        <- generate_BB(N        = 1000 , m             = 50 ,
                              num_seed = 100  , multiple_node = 100,
                              s        = 10)
    net_stats  <- get_statistics(net)
    result     <- joint_estimate(net, net_stats)
    print(result$estimate_result)
  }
}


## Script to simulate wage and educational data for the Prediction paper

## Load libraries
library(foreign)
library(xgboost)
library(tidyverse)
library(caret)
library(randomForest)
library(doParallel)

source("src/functions.r")

# read data from 2018 GSS to use as sampling distribution
data <- read.dta("data/mincerian/GSS2018.dta")
n_obs <- 50000
set.seed(1704)

# transform data to only include working age individuals and
# include broad bins to sample from
df <- data %>%
  filter(age >= 18,
         age <= 65,
         !is.na(educ)) %>%
  mutate(age_cat = ifelse(age < 25, "18_24",
      ifelse(age < 35, "25_34",
          ifelse(age < 50, "35_49", "50_65")
      )
  ))

# generate a sampling frame based on education and age category
# not using each age separately to ensure reasonable distributions
educ_age_props <- count(df, educ, age_cat, wt = wtss) %>%
    mutate(
        prop = n / sum(n),
        cum_prop = cumsum(prop)
    )

# sample from the educ x age categories and draw actual ages uniformly
new_sample <- sample_n(educ_age_props, size = n_obs, weight = n, replace = T)

new_sample$age <- ifelse(new_sample$age_cat == "18_24",
    round(runif(dim(new_sample)[1], 18, 24)),
    ifelse(new_sample$age_cat == "25_34",
        round(runif(dim(new_sample)[1], 25, 34)),
        ifelse(new_sample$age_cat == "35_49",
            round(runif(dim(new_sample)[1], 35, 49)),
            round(runif(dim(new_sample)[1], 50, 65))
        )
    )
)

# generate independent variables for regression analysis
analysis_df <- new_sample %>%
    mutate(
        S = as.numeric(educ),
        X = age - educ - 6,
        X_sq = X^2
    ) %>%
  rowwise() %>%
  mutate(S_0_8 = min(S, 8),
         S_9_10 = min(2, max(S - 8, 0)),
         S_11_12 = min(2, max(S - 10, 0)),
         S_13_14 = min(2, max(S - 12, 0)),
         S_15p = max(S - 14, 0)) %>%
  ungroup()

# randomly assign rows to male or female for gender illustration
analysis_df$gender <- ifelse(runif(dim(analysis_df)[1], 0, 1) > 0.5, 1, 0)

# simulate log wage based on linear additive models based on recent research
simul_df <- analysis_df %>%
    mutate(
        epsilon = rnorm(dim(analysis_df)[1], 0, 0.1),
        ln_y_I = 4.5 + 0.125 * S + 0.09 * X + epsilon,
        ln_y_II = 4.5 + 0.125 * S + 0.09 * X - 0.001 * X^2 + epsilon,
        ln_y_III = 4.5 + 0.02 * S_0_8 + 0.03 * S_9_10 + 0.30 * S_11_12 +
            0.06 * S_13_14 + 0.06 * S_15p + 0.09 * X - 0.001 * X^2 + epsilon
        ) %>%
    mutate(id = 1:dim(analysis_df)[1])

# define functional forms to estimate
form_0 <- as.formula("ln_y ~ 1")
form_1 <- as.formula("ln_y ~ 1 + S + X")
form_2 <- as.formula("ln_y ~ 1 + S + X + X_sq")
form_3 <- as.formula("ln_y ~ 1 + S_0_8 + S_9_10 + S_11_12 + S_13_14 + S_15p + X + X_sq")

# save list of functional forms
formulas <- list(form_0, form_1, form_2, form_3)

# run simulation to generate n_simul datasets and analyze OOS performance

n_simul <- 1000
cores <- detectCores()
cl <- makeCluster(cores[1] - 2)
registerDoParallel(cl)

results <- foreach(i = 1 : n_simul, .combine = rbind,
                   .packages = c("MASS", "Metrics", "caret", "xgboost",
                   "tidyverse")) %dopar% {
  # set seed equal to loop to ensure ability to re-engineer a specific draw's data
  set.seed(i)
  # make train set
  train_set <- simul_df %>%
    sample_frac(0.7)
  test_set <- simul_df %>%
    filter(!(id %in% train_set$id))
  stopifnot(dim(train_set)[1] + dim(test_set)[1] == dim(simul_df)[1])

  # run models: all four linear functional forms on all four datasets
  lm_1 <- LM_fits(formulas, train_set, test_set, "ln_y_I")[[2]]
  lm_2 <- LM_fits(formulas, train_set, test_set, "ln_y_II")[[2]]
  lm_3 <- LM_fits(formulas, train_set, test_set, "ln_y_III")[[2]]

  # run models: GB model on all four datasets
  gb_1 <- fit_xgb(train_set = train_set, test_set = test_set, y_var = "ln_y_I")
  gb_2 <- fit_xgb(train_set = train_set, test_set = test_set, y_var = "ln_y_II")
  gb_3 <- fit_xgb(train_set = train_set, test_set = test_set, y_var = "ln_y_III")

  list(
      lm_1[[1]], lm_1[[2]], lm_1[[3]], lm_1[[4]],
      lm_2[[1]], lm_2[[2]], lm_2[[3]], lm_2[[4]],
      lm_3[[1]], lm_3[[2]], lm_3[[3]], lm_3[[4]],
      gb_1, gb_2, gb_3
  )
}

df_results <- as.data.frame(results)
names(df_results) <- c(
    "lm_1_bench", "lm_1_1", "lm_1_2", "lm_1_3",
    "lm_2_bench", "lm_2_1", "lm_2_2", "lm_2_3",
    "lm_3_bench", "lm_3_1", "lm_3_2", "lm_3_3",
    "gb_1", "gb_2", "gb_3"
)

i <- names(df_results)[[1]]

for (i in names(df_results)) {
    df_results[[i]] <- as.numeric(df_results[[i]])
}

df_results <- readRDS("data/to_plot/mincerian.rds")
df <- df_results %>%
  mutate(lm_1_1 = 1 - (lm_1_1 / lm_1_bench),
         lm_1_2 = 1 - (lm_1_2 / lm_1_bench),
         lm_1_3 = 1 - (lm_1_3 / lm_1_bench),
         lm_2_1 = 1 - (lm_2_1 / lm_2_bench),
         lm_2_2 = 1 - (lm_2_2 / lm_2_bench),
         lm_2_3 = 1 - (lm_2_3 / lm_2_bench),
         lm_3_1 = 1 - (lm_3_1 / lm_3_bench),
         lm_3_2 = 1 - (lm_3_2 / lm_3_bench),
         lm_3_3 = 1 - (lm_3_3 / lm_3_bench),
         gb_1 = 1 - (gb_1 / lm_1_bench),
         gb_2 = 1 - (gb_3 / lm_2_bench),
         gb_3 = 1 - (gb_3 / lm_3_bench)) %>%
  dplyr::select(-lm_1_bench, -lm_2_bench, -lm_3_bench)

df_melt <- df %>%
  reshape2::melt() %>%
  mutate(dataset = ifelse(grepl("lm_1|gb_1", variable), "Dataset I",
                          ifelse(grepl("lm_2|gb_2", variable), "Dataset II",
                                 ifelse(grepl("lm_3|gb_3", variable), "Dataset III",
                                        "Else"))),
         model = ifelse(grepl("\\d{1}_1", variable), "Linear I",
                        ifelse(grepl("\\d{1}_2", variable), "Linear II",
                               ifelse(grepl("\\d{1}_3", variable), "Linear III",
                                      ifelse(grepl("gb", variable), "XGBoost",
                                            "Other")))))

df_plot <- df_melt %>%
  group_by(variable) %>%
  summarise(mean = mean(value),
            sd = sd(value),
            model = unique(model),
            dataset = unique(dataset))

df_plot$model <- factor(df_plot$model, levels = c("XGBoost", "Linear I", "Linear II", "Linear III"))

saveRDS(df_plot, "data/to_plot/mincerian.rds")


#'---
#'title: "Score models on test set"
#'author: "Denis A. Engemann"
#'date: "7/17/2020"
#'output:
#'    html_document:
#'        code_folding:
#'            hide
#'    md_document:
#'        variant:
#'            markdown_github
#'---

#' First execrise: Load all relevant data:
#' 1. Predictions for all targets from brain
#' 2. ... from sociodemographics
#' 3. ... from sociodemographics + brain

library(data.table)
library(future.apply)
source("../../utils.r")
plan(multiprocess, workers = 4)

par_sapply <- function(...) future_sapply(..., future.seed = T)

base_path <- 'post_predictive_analysis_%s.csv'

get_inputs <- function(fname, input_type)
{
  DT <- read_file_parts(fname, path = './inputs/')
  # kick out unneccesary variables and average over folds (shuffle splits..).
  DT <- DT[,
    .(predicted = mean(predicted), true = true[1]),
    by = .(eid, variable, target, evaluation)]
  DT[, `:=`(eid = factor(eid), input_type = input_type)]
  DT
}

DT <- rbind(
  get_inputs(sprintf(base_path, "non_imaging"), "social"),
  get_inputs(sprintf(base_path, "imaging_non_imaging"), "social_brain")
)

DT_brain <- read_file_parts(sprintf(base_path, "full_mri"))
DT_brain <- DT_brain[,
  .(predicted = mean(predicted), true = true[1]),
  by = .(eid, target, evaluation)]

#' Now let's set a few goals.
#'
#' What?
#' 1. brain vs non-brain models within each group of socio-demographics
#' 2. brain models vs chance.
#'
#' How?
#' - out-of-sample permutation of r2 value for brain models
#' - out-of-sample permutation of difference between 2 models
#' - same for effect-sizes using bootstrap
#'
#' Output?
#' - tables

r2_score <- function(true, predicted)
{
  rss <- sum((predicted - true) ^ 2)
  tss <- sum((true - mean(true)) ^ 2)
  R2 <- 1 - rss / tss
  R2
}

DT_inf_brain <- DT_brain[evaluation == "Generalization",
  {
    dat <- na.omit(data.frame(predicted = predicted, true = true))
    perms <- 1:10000

    # permutations
    t_obs <- r2_score(true = dat$true, predicted = dat$predicted)
    perm_r2s <- par_sapply(perms, function(perm){
      set.seed(perm)
      r2_score(true = dat$true,
               predicted = sample(dat$predicted, replace = F))
    })
    t_perm <- mean(perm_r2s)
    p_val <- max(mean(t_obs < perm_r2s), 1 / length(perms))

    # bootstrap
    boot_r2s <- par_sapply(perms, function(perm){
      set.seed(perm)
      inds <- sample.int(nrow(dat), replace = T)
      r2_score(true = dat$true[inds],
               predicted = dat$predicted[inds])
    })

    .(t_obs = t_obs, t_perm  = t_perm, p_val = p_val,
      CI_low = quantile(boot_r2s, 0.025),
      CI_hi = quantile(boot_r2s, 0.975))
  }, by = .(target)]

fwrite(DT_inf_brain, "brain_inference.csv")
knitr::kable(DT_inf_brain)
tex_out_brain <- knitr::kable(DT_inf_brain[,-c("t_perm")], format = "latex")
writeLines(tex_out_brain, "brain_inference.tex")

# compute separate R2s for ech side.

DT_r2s <- DT[evaluation == "Generalization",
    {
      dat1 <- data.frame(
      predicted_soc = .SD[input_type == "social", predicted],
      true_soc = .SD[input_type == "social", true],
      eid = .SD[input_type == "social", eid]
      )
      dat2 <- data.frame(
        predicted_soc_b = .SD[input_type == "social_brain", predicted],
        true_soc_b = .SD[input_type == "social_brain", true],
        eid = .SD[input_type == "social_brain", eid]
      )
      dat <- na.omit(merge(dat1, dat2, by = "eid"))

      out <- data.frame(
        r2_score = c(
          r2_score(true = dat$true_soc_b, predicted = dat$predicted_soc_b),
          r2_score(true = dat$true_soc, predicted = dat$predicted_soc)),
        imaging = c("yes", "no")
      )
      out
    },
  .(target, variable)]

fwrite(DT_r2s, "gen_observed_r2s.csv")

DT_inf_diff <- DT[evaluation == "Generalization",
  {
    dat1 <- data.frame(
      predicted_soc = .SD[input_type == "social", predicted],
      true_soc = .SD[input_type == "social", true],
      eid = .SD[input_type == "social", eid]
    )
    dat2 <- data.frame(
      predicted_soc_b = .SD[input_type == "social_brain", predicted],
      true_soc_b = .SD[input_type == "social_brain", true],
      eid = .SD[input_type == "social_brain", eid]
    )
    dat <- na.omit(merge(dat1, dat2, by = "eid"))

    # # permutations
    t_obs <- `-`(
      r2_score(true = dat$true_soc_b, predicted = dat$predicted_soc_b),
      r2_score(true = dat$true_soc, predicted = dat$predicted_soc)
    )
    perms <- 1:10000
    perm_r2s <- par_sapply(perms, function(perm){
      set.seed(perm)
      cand <- cbind(dat$predicted_soc,
                    dat$predicted_soc_b)
      # flip columns in each row
      permuted <- do.call(rbind,
        lapply(
          1:nrow(cand),
          function(ind){
            sample(cand[ind, c(1, 2)], replace = F)
          })
      )
      r2_soc <- r2_score(true = dat$true_soc,
                         predicted = permuted[, 1])
      r2_soc_b <- r2_score(true = dat$true_soc_b,
                           predicted = permuted[, 2])
      r2_soc_b - r2_soc
    })
    t_perm <- mean(perm_r2s)
    p_val <- max(mean(abs(t_obs) < abs(perm_r2s)), 1 / length(perms))

    # bootstrap
    boot_r2s <- par_sapply(perms, function(perm){
      set.seed(perm)
      inds <- sample.int(nrow(dat), replace = T)

      r2_soc_b <- r2_score(true = dat$true_soc_b[inds],
                           predicted = dat$predicted_soc_b[inds])

      r2_soc <- r2_score(true = dat$true_soc[inds],
                         predicted = dat$predicted_soc[inds])
      r2_soc_b - r2_soc

    })

    .(t_obs = t_obs, t_perm  = t_perm, p_val = p_val,
      CI_low = quantile(boot_r2s, 0.025),
      CI_hi = quantile(boot_r2s, 0.975))
  }, by = .(target, variable)]

setorder(DT_inf_diff, target, variable)
fwrite(DT_inf_diff, "paired_diff_inference.csv")
knitr::kable(DT_inf_diff)
tex_out_diff <- knitr::kable(DT_inf_diff[,-c("t_perm")], format = "latex")
writeLines(tex_out_diff, "paired_diff_inference.tex")


data = read.csv("C:\\Users\\liu.6544\\Documents\\GitHub\\CoronavirusTransit\\doc\\excels\\correlation.csv")
wfh_pop_rate = data$Work.from.home.populuation.ratio
all_working_pop = data$All.working.population
transit_pop_rate = data$Transit.commuting.population.ratio
google_trend = data$X..Unique.users
social_rate = data$social_rate
net_post_per_capita = data$net_post_per_capita
B = data$B
pop = data$pop
pp55 = data$pp55
pp65 = data$pp65
pp75 = data$pp75
pp85 = data$employ_den

fit <- lm(B ~ work.from.home.populuation.ratio+ pp45 + black_ratio+ google_trend_Coronavirus , data=data)
summary(fit)  # show results
car::vif(fit)

library(classInt)
library(spdep)
library(RColorBrewer)
library(gstat)

fit <- lm(B ~ employ_den + black_ratio + pp45 + google_trend_Coronavirus, data=data)
summary(fit)  # show results
bptest(model)
car::vif(fit)

fit <- lagsarlm(B ~ Work.from.home.populuation.ratio +  pp45 + google_trend_Coronavirus, data=data)
summary(fit)  # show results
car::vif(fit)

fit <- lm(B ~ Work.from.home.populuation.ratio +  black_ratio + pp45 + google_trend_Coronavirus + transit_pop_rate + vehicle0_house_rate, data=data)
summary(fit)  # show results
car::vif(fit)

fit <- lm(B ~ Work.from.home.populuation.ratio +  black_ratio + pp45, data=data)
summary(fit)  # show results
car::vif(fit)

cor.test(data$female_ratio, data$black_ratio)
cor.test(data$Work.from.home.populuation.ratio, data$employ_den)

cor.test(data$median_income, data$employ_den)
cor.test(data$pp45, data$all_post_per_capita)
cor.test(data$Work.from.home.populuation.ratio, data$vehicle0_house_rate)
cor.test(data$Work.from.home.populuation.ratio, data$transit_pop_rate)
cor.test(data$median_income, data$female_ratio)
cor.test(data$black_ratio, data$median_income)
cor.test(data$black_ratio, data$vehicle0_house_rate)
cor.test(data$B, data$homeless_ratio)
cor.test(data$divergent_point, data$convergent_point)

residual = resid(fit)

par(mfrow=c(2,2))
plot(fit)

shapiro.test(data$B)


library(ggplot2)
library(tcltk)

aptbps2 <- read.csv(file = 'density-accuracy.csv', header = TRUE)

# Linux
X11() # Use windows() or quartz() if on Windows or MacOS.

# Accuracy needs to be passed in as factors to be compatible with cdplot
# change to either "bps" or "aptbps" to obtain the relevant data
accuracy <- factor(aptbps2[,"bps"])

density <- aptbps2[,"density"]

# Cube transform (only passing density glitches cdplot)
# Source: https://rcompanion.org/handbook/I_12.html
norm_density <- sign(density) * abs(density)^(1/3)

# Uncomment to save to file in the working directory
# pdf('aptbps.pdf')

cdplot(accuracy ~ norm_density, xlab="variance in density", data = aptbps2, col = c("darksalmon", "darkseagreen1"))

prompt  <- "click to close plot"
capture <- tk_messageBox(message = prompt)


data <- read.csv("ReduceSampleSize.csv",header = TRUE)

#recall
plot(x = data$Reduction, y = data$Recall, xlab = "Reduction of sample size",
     ylab = "Model performance", type = "b", pch = 17)

#precision
lines(x = data$Reduction, y = data$Precision,type = "b", pch = 16)

#f-measure
lines(x = data$Reduction, y = data$F.measure,type = "b", pch = 7)


install.packages("ggplot2")
library(tidyverse)
library(ggplot2)

###############################
########## 3.2.4 ##############
###############################

#1 Run ggplot(data = mpg). What do you see?
# Shows nothing
ggplot(data=mpg)

#2 How many rows are in mpg? How many columns?
dim(mpg)

# There are 234 rows and 11 columns

#3 What does the drv variable describe? Read the help for ?mpg to find out.

# Show data dictionary
?mpg
# drv - the type of drive train, where f = front-wheel drive, r = rear wheel drive, 4 = 4wd

#4 Make a scatterplot of hwy vs cyl.
ggplot(data=mpg) +
  geom_point(mapping = aes(x=hwy, y=cyl))

#5 What happens if you make a scatterplot of class vs drv? Why is the plot not useful?
ggplot(data=mpg) +
  geom_point(mapping = aes(x=class, y=drv))

# This plot only shows that different classes of car can have different drives but does not show which vehicles has which drive

###############################
########## 3.3.1 ##############
###############################

#1. What’s gone wrong with this code? Why are the points not blue?

ggplot(data = mpg) +
  geom_point(mapping = aes(x = displ, y = hwy, color = "blue"))

# The points are not blue because the color parameter was included in the aes arguments
# Fixed
ggplot(data = mpg) +
  geom_point(mapping = aes(x = displ, y = hwy), color = "blue")

#2 Which variables in mpg are categorical? Which variables are continuous? (Hint: type ?mpg to read the documentation for the dataset). How can you see this information when you run mpg?

# This information can be found underneath the column labels
mpg

# or this can be used
str(mpg)

#3 Map a continuous variable to color, size, and shape. How do these aesthetics behave differently for categorical vs. continuous variables?

# Continuous variable
ggplot(data = mpg) +
  geom_point(mapping = aes(x = displ, y = hwy, color=hwy, size=hwy))

# size - The data point is enlarged based on how large the value is when compared to the entire sample
# shape - A continuous variable can not be mapped to shape
# color - The color is represented as a gradient light colors being associated with a larger value

# Categorical Values:
ggplot(data = mpg) +
  geom_point(mapping = aes(x = displ, y = hwy, color=class, size=class, shape=class))

# size - The size of discrete variables is hard to discern on the plot
# shape - The shape palette can deal with a maximum of 6 discrete values because more than 6 becomes difficult to discriminate
# color - Each discrete value is represented as a different color

#4 What happens if you map the same variable to multiple aesthetics?
ggplot(data = mpg) +
  geom_point(mapping = aes(x = displ, y = hwy, color=class, size=class))

# The aesthetics mapping will return an error if teh data type of the value is not permitted (e.g. shape=continuous var), otherwise it will try to implement the mapping on the desired variable

#5 What does the stroke aesthetic do? What shapes does it work with? (Hint: use ?geom_point)
# Follow Hint
?geom_point

# Find docs here
vignette("ggplot2-specs")

# The size of the filled part is controlled by size, the size of the stroke is controlled by stroke. Each is measured in mm, and the total size of the point is the sum of the two. Note that the size is constant along the diagonal in the following figure.
sizes <- expand.grid(size = (0:3) * 2, stroke = (0:3) * 2)
ggplot(sizes, aes(size, stroke, size = size, stroke = stroke)) +
  geom_abline(slope = -1, intercept = 6, colour = "white", size = 6) +
  geom_point(shape = 21, fill = "red") +
  scale_size_identity()

#6 What happens if you map an aesthetic to something other than a variable name, like aes(colour = displ < 5)? Note, you’ll also need to specify x and y.
ggplot(data = mpg) +
  geom_point(mapping = aes(x = displ, y = hwy, color=displ<5))
# This creates a threshold where the color will change based on the condition bring passed

###############################
########## 3.5.1 ##############
###############################

#1. What happens if you facet on a continuous variable?
ggplot(data = mpg) +
  geom_point(mapping = aes(x = displ, y = hwy)) +
  facet_grid(~ cty)

# It will create too many facets based on every continuous value seen in the sample

#2 What do the empty cells in plot with facet_grid(drv ~ cyl) mean? How do they relate to this plot?
ggplot(data = mpg) +
  geom_point(mapping = aes(x = displ, y = hwy)) +
  facet_grid(drv ~ cyl)
# The empty cells represent that there were no vehicles with the faceted vales (drv ~ cyl)

#3 What plots does the following code make? What does . do?
ggplot(data = mpg) +
  geom_point(mapping = aes(x = displ, y = hwy)) +
  facet_grid(drv ~ .)

ggplot(data = mpg) +
  geom_point(mapping = aes(x = displ, y = hwy)) +
  facet_grid(. ~ cyl)

# "." Lets you choose whether you want to facet in the rows or columns dimmension

#4 Take the first faceted plot in this section: What are the advantages to using faceting instead of the colour aesthetic? What are the disadvantages? How might the balance change if you had a larger dataset?

ggplot(data = mpg) +
  geom_point(mapping = aes(x = displ, y = hwy)) +
  facet_wrap(~ class, nrow = 2)

# Faceting in this situation makes it easier to discern between classes versus having all points on a single plot binned by different colors
# The disadvantage is you have to look at multiple plots when in some cases it may be beneficial to plot both classes on a single plot

#5 Read ?facet_wrap. What does nrow do? What does ncol do? What other options control the layout of the individual panels? Why doesn’t facet_grid() have nrow and ncol arguments?
?facet_wrap

#nrow - number of rows
#ncol - number of columns
#scales - Should scales be fixed ("fixed", the default), free ("free"), or free in one dimension ("free_x", "free_y")?

# The rows and cols of facet_grid are determined by the variables passed into the method and not by the user.

#6 When using facet_grid() you should usually put the variable with more unique levels in the columns. Why?
# Most screens are oriented rectangularly so by putting a variable with more unique classes in the columns section will help maximize screen real estate.

###############################
########## 3.6.1 ##############
###############################

#1. What geom would you use to draw a line chart? A boxplot? A histogram? An area chart?
# line chart - geom_line, geom_step, geom_path
# boxplot - geom_boxplot
# histogram - geom_histogram
# area chart - geom_area

#2 Run this code in your head and predict what the output will look like. Then, run the code in R and check your predictions.
ggplot(data = mpg, mapping = aes(x = displ, y = hwy, color = drv)) +
  geom_point() +
  geom_smooth(se = FALSE)

#3 What does show.legend = FALSE do? What happens if you remove it? Why do you think I used it earlier in the chapter?
# It removes the legend from the chart
# It was used earlier in the chapter because the legend could add confusion to the plot since some lines were the same color.

#4 What does the se argument to geom_smooth() do?
?geom_smooth
# Display confidence interval around smooth, (TRUE by default, see level to control.)

#5 Will these two graphs look different? Why/why not?
ggplot(data = mpg, mapping = aes(x = displ, y = hwy)) +
  geom_point() +
  geom_smooth()

ggplot() +
  geom_point(data = mpg, mapping = aes(x = displ, y = hwy)) +
  geom_smooth(data = mpg, mapping = aes(x = displ, y = hwy))

# They look the same, the only difference is where the arguments are passed

#6 Recreate the R code necessary to generate the following graphs.
ggplot(mpg, aes(displ, hwy)) +
  geom_point() +
  geom_smooth(se = F)

ggplot(mpg, aes(displ, hwy)) +
  geom_point() +
  geom_smooth(aes(group = drv), se = F)

ggplot(mpg, aes(displ, hwy, colour = drv)) +
  geom_smooth(se = F) +
  geom_point()
ggplot(mpg, aes(displ, hwy)) +
  geom_point(aes(colour = drv)) +
  geom_smooth(se = F)

ggplot(mpg, aes(displ, hwy)) +
  geom_point(aes(colour = drv)) +
  geom_smooth(aes(linetype = drv), se = F)

ggplot(mpg, aes(displ, hwy)) +
  geom_point(aes(fill = drv), shape = 21, stroke = 2, colour = "white", size = 3)

###############################
########## 3.7.1 ##############
###############################

# 1. What is the default geom associated with stat_summary()? How could you rewrite the previous plot to use that geom function instead of the stat function?
?stat_summary
# Default geom is pointrange
ggplot(data = diamonds) +
  geom_pointrange(
    mapping = aes(x = cut, y = depth),
    stat = "summary",
    fun.min = min,
    fun.max = max,
    fun = median)

#2 What does geom_col() do? How is it different to geom_bar()?
?geom_col

# There are two types of bar charts: geom_bar() and geom_col(). geom_bar() makes the height of the bar proportional to the number of cases in each group (or if the weight aesthetic is supplied, the sum of the weights). If you want the heights of the bars to represent values in the data, use geom_col() instead. geom_bar() uses stat_count() by default: it counts the number of cases at each x position. geom_col() uses stat_identity(): it leaves the data as is.

#3 Most geoms and stats come in pairs that are almost always used in concert. Read through the documentation and make a list of all the pairs. What do they have in common?
# You can see the pairs under the "Stats" section https://ggplot2.tidyverse.org/reference/

#4 What variables does stat_smooth() compute? What parameters control its behaviour?
?stat_smooth
# Aids the eye in seeing patterns in the presence of overplotting. geom_smooth() and stat_smooth() are effectively aliases: they both use the same arguments. Use stat_smooth() if you want to display the results with a non-standard geom.

#5 In our proportion bar chart, we need to set group = 1. Why? In other words what is the problem with these two graphs?
ggplot(data = diamonds) +
  geom_bar(mapping = aes(x = cut, y = after_stat(prop)))
ggplot(data = diamonds) +
  geom_bar(mapping = aes(x = cut, fill = color, y = after_stat(prop)))

# The group aesthetic is by default set to the interaction of all discrete variables in the plot. This choice often partitions the data correctly, but when it does not, or when no discrete variable is used in the plot, you will need to explicitly define the grouping structure by mapping group to a variable that has a different value for each group.
ggplot(data = diamonds) +
  geom_bar(mapping = aes(x = cut, fill = color, y = after_stat(prop), group=1))

# Each cut group is treated as separate group that sums to 1, by specifying group=1 you put all cut groups in the same group when proportions are calculated

###############################
########## 3.8.1 ##############
###############################

#1. What is the problem with this plot? How could you improve it?
ggplot(data = mpg, mapping = aes(x = cty, y = hwy)) +
  geom_point()

# There are a lot of overlapping points and jitter can help with this overplotting problem

#2. What parameters to geom_jitter() control the amount of jittering?
?geom_jitter
# Width and Height
ggplot(data = mpg, mapping = aes(x = cty, y = hwy)) +
  geom_point() +
  geom_jitter(width = 3, height = 4)

#3 Compare and contrast geom_jitter() with geom_count().
?geom_jitter
?geom_count

ggplot(data = mpg, mapping = aes(x = cty, y = hwy)) +
  geom_point() +
  geom_jitter()

ggplot(data = mpg, mapping = aes(x = cty, y = hwy)) +
  geom_point() +
  geom_count()

# One adds jitter to plots the other counts how many points are overlapping.

#4. What’s the default position adjustment for geom_boxplot()? Create a visualisation of the mpg dataset that demonstrates it.
ggplot(data = mpg, mapping = aes(x = class, y = displ)) +
  geom_boxplot(aes(colour = drv))


time.series.cluster.timepoint <- function(otus.normalized, distances, timepoint){

  # cluster distances using k-medoids
  max_nr_of_clusters <- nrow(otus.normalized) - 1
  clustering.instances <- lapply(2:max_nr_of_clusters, function(nr_of_clusters){
    kmedoids <- pam(distances, nr_of_clusters, diss = T)
    calinski_harabasz_index <- calinhara(otus.normalized, kmedoids$clustering, nr_of_clusters)
    silhouette_index <- kmedoids$silinfo$avg.width
    list('clustering' = kmedoids$clustering, 'ch_benchmark' = calinski_harabasz_index, 'slh_benchmark' = silhouette_index)
  })

  ch_benchmark_list <- unlist(lapply(clustering.instances, function(instance){instance$ch_benchmark}))
  slh_benchmark_list <- unlist(lapply(clustering.instances, function(instance){instance$slh_benchmark}))

  best_clustering_index_by_slh <- which(slh_benchmark_list == max(slh_benchmark_list))
  maxL <- (length(ch_benchmark_list) / 2) + 1
  best_clustering_index_by_ch <- which(ch_benchmark_list == max(ch_benchmark_list[1:maxL]))

  best_nr_of_clusters_by_slh <- best_clustering_index_by_slh + 1
  best_nr_of_clusters_by_ch <- best_clustering_index_by_ch + 1

  best_clustering_by_slh <- clustering.instances[[best_clustering_index_by_slh]]$clustering
  best_clustering_by_ch <- clustering.instances[[best_clustering_index_by_ch]]$clustering

  # build result
  result <- list('best.clustering_by_slh' = best_clustering_by_slh,
                 'best.clustering_by_ch' = best_clustering_by_ch,
                 'best.nr.of.clusters_by_slh' = best_nr_of_clusters_by_slh,
                 'best.nr.of.clusters_by_ch' = best_nr_of_clusters_by_ch,
                 'ch_benchmark_list' = ch_benchmark_list,
                 'slh_benchmark_list' = slh_benchmark_list,
                 'timepoint' = timepoint,
                 'distances' = distances)

  return (result)
}

time.series.generate.clusterings <- function(otus, otus.tree){

  # execute analysis per timepoint
  clusterings <- lapply(unique.timepoints, function(timepoint){

    # filter otus with timepoint
    otus.of.timepoints <- otus.all.records.for.timepoints(otus, timepoint)

    # normalize otus
    otus.normalized <- otus.normalize(otus.of.timepoints, 0)

    # calcuate distances
    distances <- distances.calculate(otus.normalized, otus.tree)

    # cluster data
    time.series.cluster.timepoint(otus.normalized, distances, timepoint)
  })

  return(clusterings)
}

time.series.generate <- function(clusterings, samples){

  individuals <- unlist(lapply(samples, function(i){substr(i, start = 2, stop = 4)}))
  timepoints <- unlist(lapply(samples, function(i){substr(i, start = 5, stop = 7)}))

  time.series <- matrix(nrow = length(unique(individuals)), ncol = length(unique(timepoints)))
  row.names(time.series) <- unique(individuals)
  colnames(time.series) <- unique(timepoints)

  for (clustering in clusterings)
  {
    for (individual in unique(individuals))
    {
      timepoint <- clustering$timepoint
      sample = paste('X', individual, timepoint, sep = '')
      time.series[individual, timepoint] = clustering$best.clustering_by_ch[sample]
    }
  }

  return(time.series)
}


function(data){
#This data computes slopes, intercepts, boundaries, and shifts for
#two grid tests in the crazy beliefs study.
#
# data should be a matrix containing data from two grid tests as follows:
#Subject	TrialNo	Ttype	CookRaw	FarSrc	Pic	Response	RT
#1	1	Grid1	C	L	100	1	4009
#1	2	Grid1	C	L	80	1	1503
#
#Function returns a matrix where each row is a subject and fields note
#experiment conditions and the decision curves for each subject in each
#grid test.

sjs<-unique(data$Subject)  #make a vector contaning all the unique subject numbers
nsjs<-length(sjs)

t1 <- matrix(0, nsjs, 2)	#create two temporary matrices to hold
t2<-t1				#test 1 and test 2 paramter estimates

#create temporary matrix to hold other data

cond<-cbind(sjs, rep("E", times = nsjs), rep("E", times = nsjs))

#Loop over subjects to get logistic parameters estimates for
#test 1 and test 2
for(i1 in c(1:nsjs)){
	sdat <- subset(data, data$Subject==sjs[i1] & data$Ttype=="Grid1") 	#pull out grid 1 data for current subject
	tmod1<- glm(Response~Pic, data = sdat, family="binomial") 		#fit test 1 model
	sdat <- subset(data, data$Subject==sjs[i1] & data$Ttype=="Grid2") 	#pull out grid 2 data for current subject
	tmod2<- glm(Response~Pic, data = sdat, family="binomial") 		#fit test 2 model
	t1[i1,]<-tmod1$coefficients 					#store test 1 coefficients
	t2[i1,]<-tmod2$coefficients					#store test 2 coefficients
	sdat[,4]<-as.character(sdat[,4])					#change conditions from factor to string object
	sdat[,5]<-as.character(sdat[,5])
	cond[i1,2:3]<-as.character(sdat[1, 4:5])			#pull out other info about this sj and condition
	}								#and store in cond matrix

b1<- -1 * t1[,1]/t1[,2]		#estimate boundary for test 1
b2<- -1 * t2[,1]/t2[,2]		#estimate boundary for test 2

cond<-as.data.frame(cond)	#convert cond matrix to data-frame object

#out <- cbind(t1,b1,t2,b2)

out<-cbind(cond,t1,b1,t2,b2) 	#glue condition, t1, and t2 matrices together in data frame
names(out)<-c("sno", "axlab","group","t1int","t1slope","t1bound","t2int","t2slope","t2bound") #name columns
bshift <- b2 - b1		#compute shift in boundary
midshift <- bshift		#copy bshift to midshift

#Flip direction for people in right-biased group
#so positive numbers mean toward midline and negative numbers mean
#away from midline:
midshift[out$group=="R"] <- midshift[out$group=="R"] * -1

out<-cbind(out, bshift, midshift) #glue boundary shift data to output dataframe

Zmidshift <- (out$midshift - mean(out$midshift))/sqrt(var(out$midshift))  #compute Zscore for midshift across all conditions
out<-cbind(out, Zmidshift) #glue Zscores onto ouput data frame
out #output result
}


qr.coef(qr(X), y)


#' Wald test for model fits
#'
#' @inheritParams  fit
#' @return  a data.frame with terms, their fitted values, and wald statistic
wald = function(x, y, weights=rep(1,nrow(x)), offset=0, control=list(),
                lower=-Inf, upper=Inf, verbose=FALSE) {
    res = do.call(fit, c(as.list(match.call())[-1],
                  list(hessian=TRUE, verbose=verbose)),
                  envir=parent.frame())

    # we are minimizing the negative log likelihood, so the covariance matrix
    # is the hessian; diagonalizing and taking those elements, we get the
    # variance (which is the standard error squared)
    beta_se = tryCatch(sqrt(pmax(diag(solve(res$hessian)), 0)),
                       error = function(e) NA)
    wald = res$par / beta_se
    pval = 2 * stats::pnorm(abs(wald), lower.tail=FALSE)
    # pval = 2 * stats::pt(abs(wald), df=df, lower.tail=FALSE)

    # assemble results
    data.frame(term=names(res$par), estimate=res$par, statistic=wald,
               p.value=pval, check.names=FALSE, row.names=NULL)
}