\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)
}


# Process D47 data for plotting in manuscript

require(tidyverse) # for data treatment
require(bfsl) # for York regressions

# Load combined aragonite dataset
dat <- as.data.frame(read.csv("01_Aragonite_compilation.csv", header = TRUE))
dat$sample <- paste(dat$Temp, dat$Analysis, sep = "_")

source("03_Average_error_propagation.r")

# ------------------------Summarize stats per data ID---------------------------

# First propagate uncertainties on bins per temperature, keeping data from different machines separate
D47stats_Machinebin <- dat[which(dat$D47_outlier != TRUE),] %>% # Summarize D47 statistics
    group_by(ID, Machine) %>%
    summarize(
        Temp = mean(Temp, na.rm = TRUE),
        Temp_SD = first(Temp_SD),
        Analysis = first(Analysis),
        type = first(type),
        sample = first(sample),
        D47_binmean = mean(D47, na.rm = TRUE),  # Calculate means per sample
        SD_bin = sd(D47, na.rm = TRUE), # Calculate stdevs per sample bin
        SD_ext = first(D47_SD), # External standard deviation (reported or based on check STD)
        binsd = if(is.na(SD_bin)){first(SD_ext)}else{max(SD_bin, SD_ext)}, # Find largest standard deviation
        Nbin = n(), # Calculate the number of modelled values, excluding NA's
        binse = binsd / sqrt(Nbin), # Calculate the standard error
        binCL95 = qt(0.95, Nbin) * binse, # Calculate the 95% confidence level
        param49_binmean = mean(param49, na.rm = TRUE), # Propagate param49 mean per sample
        param49_binsd = sd(param49, na.rm = TRUE), # Propagate param49 SD per sample
        Machine = first(Machine)
    ) %>%
    ungroup()

# write.csv(D47stats_Machinebin, "E:/Dropbox//Research//postdoc//UNBIAS//Clumped Temperature Calibration/Aragonite_dataset_stats_by_Machine.csv")

# Now combine sample groups from different machines into one bin
D47stats <- D47stats_Machinebin %>%
    group_by(ID) %>%
    summarize(
        Temp = mean(Temp, na.rm = TRUE),
        Temp_SD = first(Temp_SD),
        Analysis = first(Analysis),
        type = first(type),
        sample = first(sample),
        D47_mean = binmeans(x = D47_binmean, x_sd = binsd, n = Nbin, output = "mean"),  # Calculate means per sample
        sd = binmeans(x = D47_binmean, x_sd = binsd, n = Nbin, output = "SD"), # Calculate stdevs per sample bin
        N = sum(Nbin, na.rm = TRUE), # Calculate the number of modelled values, excluding NA's
        se = sd / sqrt(N), # Calculate the standard error
        CL95 = qt(0.95, N) * se, # Calculate the 95% confidence level
        param49_mean = binmeans(x = param49_binmean, x_sd = param49_binsd, n = Nbin, output = "mean"),  # Calculate means per sample
        param49_sd = binmeans(x = param49_binmean, x_sd = param49_binsd, n = Nbin, output = "SD"), # Calculate stdevs per sample bin
        param49_se = param49_sd / sqrt(N),
        param49_CL95 = qt(0.95, N) * param49_se
    )

# write.csv(D47stats, "E:/Dropbox//Research//postdoc//UNBIAS//Clumped Temperature Calibration/Aragonite_dataset_stats_grouped.csv")

# Summarize stats for Arctica islandica samples per specimen
# First propagate uncertainties on bins per specimen, keeping data from different machines separate
Aisstats_Machinebin <- dat[which(dat$D47_outlier != TRUE & dat$Analysis == "this study"), ] %>% # Summarize D47 statistics
    group_by(Specimen, Machine) %>%
    summarize(
        sample = first(sample),
        Temp = mean(Temp, na.rm = TRUE),
        Temp_SD = first(Temp_SD),
        Analysis = first(Analysis),
        type = first(type),
        sample = first(sample),
        D47_binmean = mean(D47, na.rm = TRUE),  # Calculate means per sample
        SD_bin = sd(D47, na.rm = TRUE), # Calculate stdevs per sample bin
        SD_ext = first(D47_SD), # External standard deviation (reported or based on check STD)
        binsd = max(SD_bin, SD_ext), # Find largest standard
        Nbin = n(), # Calculate the number of modelled values, excluding NA's
        binse = binsd / sqrt(Nbin), # Calculate the standard error
        binCL95 = qt(0.95, Nbin) * binse, # Calculate the 95% confidence level
        param49_binmean = mean(param49, na.rm = TRUE), # Propagate param49 mean per sample
        param49_binsd = sd(param49, na.rm = TRUE), # Propagate param49 SD per sample
        Machine = first(Machine)
    ) %>%
    ungroup()

# write.csv(Aisstats_Machinebin, "E:/Dropbox//Research//postdoc//UNBIAS//Clumped Temperature Calibration/Ais_dataset_stats_by_Machine.csv")

# Now combine sample groups from different machines into one bin
Aisstats <- Aisstats_Machinebin %>%
    group_by(Specimen) %>%
    summarize(
        Temp = mean(Temp, na.rm = TRUE),
        Temp_SD = first(Temp_SD),
        Analysis = first(Analysis),
        type = first(type),
        sample = first(sample),
        D47_mean = binmeans(x = D47_binmean, x_sd = binsd, n = Nbin, output = "mean"),  # Calculate means per sample
        sd = binmeans(x = D47_binmean, x_sd = binsd, n = Nbin, output = "SD"), # Calculate stdevs per sample bin
        N = sum(Nbin, na.rm = TRUE), # Calculate the number of modelled values, excluding NA's
        se = sd / sqrt(N), # Calculate the standard error
        CL95 = qt(0.95, N) * se, # Calculate the 95% confidence level
        param49_mean = binmeans(x = param49_binmean, x_sd = param49_binsd, n = Nbin, output = "mean"),  # Calculate means per sample
        param49_sd = binmeans(x = param49_binmean, x_sd = param49_binsd, n = Nbin, output = "SD"), # Calculate stdevs per sample bin
        param49_se = param49_sd / sqrt(N),
        param49_CL95 = qt(0.95, N) * param49_se
    )

# write.csv(Aisstats, "E:/Dropbox//Research//postdoc//UNBIAS//Clumped Temperature Calibration/Ais_dataset_stats_grouped.csv")

# Update dat with new propagated SDs for regressions
newSDs <- D47stats[which(D47stats$Analysis == "this study"), which(colnames(D47stats) %in% c("ID", "sd"))]
dat$D47_SD[which(!is.na(match(dat$ID, newSDs$ID)))] <- newSDs$sd[match(dat$ID, newSDs$ID)[which(!is.na(match(dat$ID, newSDs$ID)))]]

# Monte Carlo sample from individual aliquot distributions for violin plots and polynomial regression including errors on D47
Nsim <- 10 ^ 4
violin_data <- data.frame(sample = rep(dat$sample, Nsim),
    type = rep(dat$type, Nsim),
    Analysis = rep(dat$Analysis, Nsim),
    ID = rep(dat$ID, Nsim),
    Specimen = rep(dat$Specimen, Nsim),
    Temp = rep(dat$Temp, Nsim),
    Temp_sampled = rnorm(Nsim * length(dat$Temp), dat$Temp, dat$Temp_SD),
    D47 = rnorm(Nsim * length(dat$D47), dat$D47, dat$D47_SD),
    param49 = rnorm(Nsim * length(dat$param49), dat$param49, dat$param49_sd),
    outlier = rep(dat$D47_outlier, Nsim)
)

violin_data$x <- 10 ^ 6 / (violin_data$Temp_sampled + 273.15) ^ 2 # Create 10^6/T^2 vector

# ------------------------Pairwise comparisons----------------------------------

Aisdata <- dat[which(dat$D47_outlier != TRUE & dat$Analysis == "this study"), ] # Isolate Arctica islandica data from this study
Ais_temp_aov <- aov(D47 ~ ID, data = Aisdata) # Conduct one-way ANOVA on temperature bins

capture.output(summary(Ais_temp_aov), file = "out/is_Pairwise_comp_temp_summary.txt") # Print summary of ANOVA
TukeyHSD(Ais_temp_aov) # Print results of Tukey multiple pairwise-comparisons (post-hoc Tukey's test) on temperature bins
write.csv(TukeyHSD(Ais_temp_aov)$ID, "out/is_Pairwise_comp_temp.csv") # Export summary of Tukey multiple pairwise-comparisons

Ais_spec1_aov <- aov(D47 ~ Specimen, data = Aisdata[which(Aisdata$Temp == 1.1), ]) # Conduct one-way ANOVA on Specimen bins within the 1 degree temperature treatment
capture.output(summary(Ais_spec1_aov), file = "out/is_Pairwise_comp_spec1_summary.txt") # Print summary of ANOVA
TukeyHSD(Ais_spec1_aov) # Print results of Tukey multiple pairwise-comparisons (post-hoc Tukey's test) on specimen bins
write.csv(TukeyHSD(Ais_spec1_aov)$Specimen, "out/is_Pairwise_comp_spec1.csv") # Export summary of Tukey multiple pairwise-comparisons

Ais_spec18_aov <- aov(D47 ~ Specimen, data = Aisdata[which(Aisdata$Temp == 18.0), ]) # Conduct one-way ANOVA on Specimen bins within the 18 degree temperature treatment
capture.output(summary(Ais_spec18_aov), file = "out/is_Pairwise_comp_spec18_summary.txt") # Print summary of ANOVA
TukeyHSD(Ais_spec18_aov) # Print results of Tukey multiple pairwise-comparisons (post-hoc Tukey's test) on specimen bins
write.csv(TukeyHSD(Ais_spec18_aov)$Specimen, "out/is_Pairwise_comp_spec18.csv") # Export summary of Tukey multiple pairwise-comparisons

# ----------------------------Regressions---------------------------------------

# TLinear York regression both with and without high temperature datapoints
D47m_York <- bfsl(x = 10^6 / (dat$Temp[dat$D47_outlier == FALSE] + 273.15) ^ 2,
    y = dat$D47[dat$D47_outlier == FALSE],
    sd_x = abs(10^6 / (dat$Temp[dat$D47_outlier == FALSE] + dat$Temp_SD[dat$D47_outlier == FALSE] + 273.15) ^ 2 - 10^6 / (dat$Temp[dat$D47_outlier == FALSE] - dat$Temp_SD[dat$D47_outlier == FALSE] + 273.15) ^ 2) / 2,
    sd_y = dat$D47_SD[dat$D47_outlier == FALSE],
    r = 0)
newdat_York <- data.frame(x = 10 ^6 / (seq(0, 1000, 0.1) + 273.15) ^ 2)
D47m_York_pred <- predict(D47m_York, newdata = newdat_York, se.fit = TRUE, interval = "confidence", level = 0.95)
D47m_York_result <- cbind(newdat_York, D47m_York_pred$fit)

D47m_lowT_York <- bfsl(x = 10^6 / (dat$Temp[dat$D47_outlier == FALSE & dat$Analysis != "Muller17"] + 273.15) ^ 2,
    y = dat$D47[dat$D47_outlier == FALSE & dat$Analysis != "Muller17"],
    sd_x = abs(10^6 / (dat$Temp[dat$D47_outlier == FALSE & dat$Analysis != "Muller17"] + dat$Temp_SD[dat$D47_outlier == FALSE & dat$Analysis != "Muller17"] + 273.15) ^ 2 - 10^6 / (dat$Temp[dat$D47_outlier == FALSE & dat$Analysis != "Muller17"] - dat$Temp_SD[dat$D47_outlier == FALSE & dat$Analysis != "Muller17"] + 273.15) ^ 2) / 2,
    sd_y = dat$D47_SD[dat$D47_outlier == FALSE & dat$Analysis != "Muller17"],
    r = 0)
newdat_lowT_York <- data.frame(x = 10 ^6 / (seq(0, 100, 0.1) + 273.15) ^ 2)
D47m_lowT_York_pred <- predict(D47m_lowT_York, newdata = newdat_lowT_York, se.fit = TRUE, interval = "confidence", level = 0.95)
D47m_lowT_York_result <- cbind(newdat_lowT_York, D47m_lowT_York_pred$fit)

# Calculate linear York regression on A. islandica and all bivalve data
Ais_York <- bfsl(x = 10^6 / (dat$Temp[dat$D47_outlier == FALSE & (dat$Analysis == "this study" | dat$ID == "A.islandica")] + 273.15) ^ 2,
    y = dat$D47[dat$D47_outlier == FALSE & (dat$Analysis == "this study" | dat$ID == "A.islandica")],
    sd_x = abs(10^6 / (dat$Temp[dat$D47_outlier == FALSE & (dat$Analysis == "this study" | dat$ID == "A.islandica")] + dat$Temp_SD[dat$D47_outlier == FALSE & (dat$Analysis == "this study" | dat$ID == "A.islandica")] + 273.15) ^ 2 - 10^6 / (dat$Temp[dat$D47_outlier == FALSE & (dat$Analysis == "this study" | dat$ID == "A.islandica")] - dat$Temp_SD[dat$D47_outlier == FALSE & (dat$Analysis == "this study" | dat$ID == "A.islandica")] + 273.15) ^ 2) / 2,
    sd_y = dat$D47_SD[dat$D47_outlier == FALSE & (dat$Analysis == "this study" | dat$ID == "A.islandica")],
    r = 0)
Ais_York_pred <- predict(Ais_York, newdata = newdat_lowT_York, se.fit = TRUE, interval = "confidence", level = 0.95)
Ais_York_result <- cbind(newdat_lowT_York, Ais_York_pred$fit)

Mollusk_York <- bfsl(x = 10^6 / (dat$Temp[dat$D47_outlier == FALSE & (dat$Analysis == "this study" | dat$ID == "A.islandica" | dat$Analysis == "Caldarescu21")] + 273.15) ^ 2,
    y = dat$D47[dat$D47_outlier == FALSE & (dat$Analysis == "this study" | dat$ID == "A.islandica" | dat$Analysis == "Caldarescu21")],
    sd_x = abs(10^6 / (dat$Temp[dat$D47_outlier == FALSE & (dat$Analysis == "this study" | dat$ID == "A.islandica" | dat$Analysis == "Caldarescu21")] + dat$Temp_SD[dat$D47_outlier == FALSE & (dat$Analysis == "this study" | dat$ID == "A.islandica" | dat$Analysis == "Caldarescu21")] + 273.15) ^ 2 - 10^6 / (dat$Temp[dat$D47_outlier == FALSE & (dat$Analysis == "this study" | dat$ID == "A.islandica" | dat$Analysis == "Caldarescu21")] - dat$Temp_SD[dat$D47_outlier == FALSE & (dat$Analysis == "this study" | dat$ID == "A.islandica" | dat$Analysis == "Caldarescu21")] + 273.15) ^ 2) / 2,
    sd_y = dat$D47_SD[dat$D47_outlier == FALSE & (dat$Analysis == "this study" | dat$ID == "A.islandica" | dat$Analysis == "Caldarescu21")],
    r = 0)
Mollusk_York_pred <- predict(Mollusk_York, newdata = newdat_lowT_York, se.fit = TRUE, interval = "confidence", level = 0.95)
Mollusk_York_result <- cbind(newdat_lowT_York, Mollusk_York_pred$fit)

# Third order polynomial regression following Müller et al., 2019 and Jautzy et al., 2020
newdat <- data.frame(Temp = seq(0, 1000, 0.1))
D47m_poly <- lm(D47 ~ poly(I(10^6 / (Temp + 273.15) ^ 2), 3), data = dat, subset = which(dat$D47_outlier == FALSE))
D47m_poly_pred <- predict.lm(D47m_poly, newdata = reaname(newdat_York, Temp = x), se.fit = TRUE, interval = "confidence", level = 0.95)
D47m_poly_result <- cbind(10^6 / (newdat + 273.15) ^2, D47m_poly_pred$fit)

# Polynomial regression with errors on D47 and Temp using MC simulation
D47m_poly_MC <- lm(D47 ~ poly(x, 3), data = violin_data, subset = which(violin_data$outlier == FALSE))
D47m_poly_MC_pred <- predict.lm(D47m_poly_MC, newdata = newdat_York, se.fit = TRUE, interval = "confidence", level = 0.95)
D47m_poly_MC_result <- cbind(newdat_York, D47m_poly_MC_pred$fit)
# Readjust 95% CL calculations for actual degrees of freedom
D47m_poly_MC_result$lwr <- D47m_poly_MC_result$fit - (D47m_poly_MC_result$fit - D47m_poly_MC_result$lwr) * sqrt(D47m_poly_MC$df.residual) / sqrt(length(violin_data$D47) / Nsim - 4)
D47m_poly_MC_result$upr <- D47m_poly_MC_result$fit + (D47m_poly_MC_result$upr - D47m_poly_MC_result$fit) * sqrt(D47m_poly_MC$df.residual) / sqrt(length(violin_data$D47) / Nsim - 4)

# -----------------------Add Preexisting calibrations---------------------------
# Add dummy data to plot Anderson calibration
Anderson21 <- data.frame(Temp = 10 ^ 6 / (seq(0, 1000, 0.1) + 273.15) ^ 2,
    D47 = 0.0391 * 10 ^ 6 / (seq(0, 1000, 0.1) + 273.15) ^ 2 + 0.154) # Latest Anderson calibration

# Add dummy data to plot Meinicke calibration
MeinickeICDES <- data.frame(Temp = 10 ^ 6 / (seq(0, 1000, 0.1) + 273.15) ^ 2,
    D47 = 0.0397 * 10 ^ 6 / (seq(0, 1000, 0.1) + 273.15) ^ 2 + 0.1518) # Recalculated Meinicke calibration

# Add theoretical calcite and aragonite calibration lines by Guo et al. 2009 recalculated to the I-CDES scale
Guo09 <- data.frame(Temp = 10 ^ 6 / (seq(0, 1000, 0.1) + 273.15) ^ 2,
    D47_cc_original = -3.33040 * 10 ^ 9 / (seq(0, 1000, 0.1) + 273.15) ^ 4 + 2.32415 * 10 ^ 7 / (seq(0, 1000, 0.1) + 273.15) ^ 3 - 2.91282 * 10 ^ 3 / (seq(0, 1000, 0.1) + 273.15) ^ 2 - 5.54042 / (seq(0, 1000, 0.1) + 273.15), # Original formula published by Guo et al., 2009
    D47_ar_original = -3.43068 * 10 ^ 9 / (seq(0, 1000, 0.1) + 273.15) ^ 4 + 2.35766 * 10 ^ 7 / (seq(0, 1000, 0.1) + 273.15) ^ 3 - 8.06003 * 10 ^ 2 / (seq(0, 1000, 0.1) + 273.15) ^ 2 - 6.90300 / (seq(0, 1000, 0.1) + 273.15), # Original formula published by Guo et al., 2009
    D47_cc_CDES25 = -3.33040 * 10 ^ 9 / (seq(0, 1000, 0.1) + 273.15) ^ 4 + 2.32415 * 10 ^ 7 / (seq(0, 1000, 0.1) + 273.15) ^ 3 - 2.91282 * 10 ^ 3 / (seq(0, 1000, 0.1) + 273.15) ^ 2 - 5.54042 / (seq(0, 1000, 0.1) + 273.15) + 0.23252 + 0.268 - 0.232, # Corrected to CDES reference fram by updating the D47-D63 fractionation factor from 0.232 to 0.268
    D47_ar_CDES25 = -3.43068 * 10 ^ 9 / (seq(0, 1000, 0.1) + 273.15) ^ 4 + 2.35766 * 10 ^ 7 / (seq(0, 1000, 0.1) + 273.15) ^ 3 - 8.06003 * 10 ^ 2 / (seq(0, 1000, 0.1) + 273.15) ^ 2 - 6.90300 / (seq(0, 1000, 0.1) + 273.15) + 0.22893 + 0.268 - 0.232, # Corrected to CDES reference fram by updating the D47-D63 fractionation factor from 0.232 to 0.268
    D47_cc_CDES90 = -3.33040 * 10 ^ 9 / (seq(0, 1000, 0.1) + 273.15) ^ 4 + 2.32415 * 10 ^ 7 / (seq(0, 1000, 0.1) + 273.15) ^ 3 - 2.91282 * 10 ^ 3 / (seq(0, 1000, 0.1) + 273.15) ^ 2 - 5.54042 / (seq(0, 1000, 0.1) + 273.15) + 0.23252 + 0.268 - 0.232 - 0.088, # Bring to CDES90 by applying the 25-70 degrees acid fractionation factor by Petersen et al., 2019
    D47_ar_CDES90 = -3.43068 * 10 ^ 9 / (seq(0, 1000, 0.1) + 273.15) ^ 4 + 2.35766 * 10 ^ 7 / (seq(0, 1000, 0.1) + 273.15) ^ 3 - 8.06003 * 10 ^ 2 / (seq(0, 1000, 0.1) + 273.15) ^ 2 - 6.90300 / (seq(0, 1000, 0.1) + 273.15) + 0.22893 + 0.268 - 0.232 - 0.088, # Bring to CDES90 by applying the 25-70 degrees acid fractionation factor by Petersen et al., 2019
    D47_cc_CDES90_corr = (-3.33040 * 10 ^ 9 / (seq(0, 1000, 0.1) + 273.15) ^ 4 + 2.32415 * 10 ^ 7 / (seq(0, 1000, 0.1) + 273.15) ^ 3 - 2.91282 * 10 ^ 3 / (seq(0, 1000, 0.1) + 273.15) ^ 2 - 5.54042 / (seq(0, 1000, 0.1) + 273.15) + 0.23252 + 0.268 - 0.232 - 0.088) * 1.035, # Correct for D47-dependent D47-D63 fractionation factor of 35 ppm/per mille found by Guo et al. 2009 (and implemented in Jautzy et al., 2020)
    D47_ar_CDES90_corr = (-3.43068 * 10 ^ 9 / (seq(0, 1000, 0.1) + 273.15) ^ 4 + 2.35766 * 10 ^ 7 / (seq(0, 1000, 0.1) + 273.15) ^ 3 - 8.06003 * 10 ^ 2 / (seq(0, 1000, 0.1) + 273.15) ^ 2 - 6.90300 / (seq(0, 1000, 0.1) + 273.15) + 0.22893 + 0.268 - 0.232 - 0.088) * 1.035 # Correct for D47-dependent D47-D63 fractionation factor of 35 ppm/per mille found by Guo et al. 2009 (and implemented in Jautzy et al., 2020)
)

# Values used to put Guo et al. 2009 data on the I-CDES scale
# ETH-1 - Iso A (Meckler et al., 2014) = 600 degr with D47 of 0.2052
# ETH-2 - Iso B (Meckler et al., 2014) = 600 degr with D47 of 0.2085
# ETH-3 - Iso C (Meckler et al., 2014) = ~20 degr with D47 of 0.6132

ETH1_GuoCDES <- Guo09$D47_ar_CDES25[which(Guo09$Temp == 10 ^ 6 / (600 + 273.15) ^ 2)]
ETH3_GuoCDES <- Guo09$D47_ar_CDES25[which(Guo09$Temp == 10 ^ 6 / (20 + 273.15) ^ 2)]
ETH1_ICDES <- 0.2052
ETH3_ICDES <- 0.6132

# Place on I-CDES scale
Guo09$D47_cc_ICDES <- (Guo09$D47_cc_CDES25 - ETH1_GuoCDES) * (ETH1_ICDES-ETH3_ICDES)/(ETH1_GuoCDES-ETH3_GuoCDES) + ETH1_ICDES # Use linear correction through ETH1 and ETH3 values to transform to I-CDES scale
Guo09$D47_ar_ICDES <- (Guo09$D47_ar_CDES25 - ETH1_GuoCDES) * (ETH1_ICDES-ETH3_ICDES)/(ETH1_GuoCDES-ETH3_GuoCDES) + ETH1_ICDES # Use linear correction through ETH1 and ETH3 values to transform to I-CDES scale
Guo09$D47_cc <- Guo09$D47_cc_ICDES * 1.035 # Correct for D47-dependent D47-D63 fractionation factor of 35 ppm/per mille found by Guo et al. 2009 (and implemented in Jautzy et al., 2020)
Guo09$D47_ar <- Guo09$D47_ar_ICDES * 1.035 # Correct for D47-dependent D47-D63 fractionation factor of 35 ppm/per mille found by Guo et al. 2009 (and implemented in Jautzy et al., 2020)

# Arctica islandica plot (Figure 1)
source("05_A_islandica_plot.r")

# Full aragonite dataset plot (Figure 2)
source("06_Full_aragonite_plot.r")

# Summarize regression stats
regstats <- data.frame(regression = c("All data York", "low T York", "A. islandica York", "Mollusk York"),
    slope = c(D47m_York$coefficients[[2]], D47m_lowT_York$coefficients[[2]], Ais_York$coefficients[[2]], Mollusk_York$coefficients[[2]]),
    slope_SE = c(D47m_York$coefficients[[4]], D47m_lowT_York$coefficients[[4]], Ais_York$coefficients[[4]], Mollusk_York$coefficients[[4]]),
    intercept = c(D47m_York$coefficients[[1]], D47m_lowT_York$coefficients[[1]], Ais_York$coefficients[[1]], Mollusk_York$coefficients[[1]]),
    intercept_SE = c(D47m_York$coefficients[[3]], D47m_lowT_York$coefficients[[3]], Ais_York$coefficients[[3]], Mollusk_York$coefficients[[3]]),
    SER = c(sqrt(sum(D47m_York$residuals ^ 2) / D47m_York$df.residual), sqrt(sum(D47m_lowT_York$residuals ^ 2) / D47m_lowT_York$df.residual), sqrt(sum(Ais_York$residuals ^ 2) / Ais_York$df.residual), sqrt(sum(Mollusk_York$residuals ^ 2) / Mollusk_York$df.residual))
)

regstats_poly <- data.frame(regression = c("Polynomial fit_means", "Polynomial fit_MC"),
    Intercept = c(summary(D47m_poly)$coefficients[1, 1], summary(D47m_poly_MC)$coefficients[1, 1]),
    Intercept_SE = c(summary(D47m_poly)$coefficients[1, 2], summary(D47m_poly_MC)$coefficients[1, 2]),
    Term1 = c(summary(D47m_poly)$coefficients[2, 1], summary(D47m_poly_MC)$coefficients[2, 1]),
    Term1_SE = c(summary(D47m_poly)$coefficients[2, 2], summary(D47m_poly_MC)$coefficients[2, 2]),
    Temm2 = c(summary(D47m_poly)$coefficients[3, 1], summary(D47m_poly_MC)$coefficients[3, 1]),
    Term2_SE = c(summary(D47m_poly)$coefficients[3, 2], summary(D47m_poly_MC)$coefficients[3, 2]),
    Term3 = c(summary(D47m_poly)$coefficients[4, 1], summary(D47m_poly_MC)$coefficients[4, 1]),
    Term3_SE = c(summary(D47m_poly)$coefficients[4, 2], summary(D47m_poly_MC)$coefficients[4, 2]),
    SER = c(sigma(D47m_poly), sigma(D47m_poly_MC))
)

# Export summary of regression stats
# write.csv(regstats, "<path>/Aragonite_calibration_regression_statistics.csv")
# write.csv(regstats_poly, "<path>/Aragonite_calibration_polynomial_regression_statistics.csv")

# -------------------------Regression residuals---------------------------------
# Extract D47 values and their errors for temperatures of all samples
newdat_York <- data.frame(x = 10 ^6 / (dat$Temp + 273.15) ^ 2)
dat$D47res_York <- dat$D47 - predict(D47m_York, newdata = newdat_York, se.fit = TRUE, interval = "none", level = 0.95)$fit
dat$D47res_lowT_York <- dat$D47 - predict(D47m_lowT_York, newdata = newdat_York, se.fit = TRUE, interval = "none", level = 0.95)$fit
dat$D47res_poly <- dat$D47 - predict(D47m_poly_MC, newdata = newdat_York, se.fit = TRUE, interval = "none", level = 0.95)$fit
dat$D47res_Anderson <- dat$D47 - (0.0391 * 10 ^ 6 / (dat$Temp + 273.15) ^ 2 + 0.154)
dat$D47res_Meinicke <- dat$D47 - (0.0397 * 10 ^ 6 / (dat$Temp + 273.15) ^ 2 + 0.1518)
dat$D47res_Guo_cc <- dat$D47 - (((-3.33040 * 10 ^ 9 / (dat$Temp + 273.15) ^ 4 + 2.32415 * 10 ^ 7 / (dat$Temp + 273.15) ^ 3 - 2.91282 * 10 ^ 3 / (dat$Temp + 273.15) ^ 2 - 5.54042 / (dat$Temp + 273.15) + 0.23252 + 0.268 - 0.232) - ETH1_GuoCDES) * (ETH1_ICDES-ETH3_ICDES)/(ETH1_GuoCDES-ETH3_GuoCDES) + ETH1_ICDES) * 1.035
dat$D47res_Guo_ar <- dat$D47 - (((-3.43068 * 10 ^ 9 / (dat$Temp + 273.15) ^ 4 + 2.35766 * 10 ^ 7 / (dat$Temp + 273.15) ^ 3 - 8.06003 * 10 ^ 2 / (dat$Temp + 273.15) ^ 2 - 6.90300 / (dat$Temp + 273.15) + 0.22893 + 0.268 - 0.232) - ETH1_GuoCDES) * (ETH1_ICDES-ETH3_ICDES)/(ETH1_GuoCDES-ETH3_GuoCDES) + ETH1_ICDES) * 1.035

newdat_York <- data.frame(x = 10 ^6 / (D47stats$Temp + 273.15) ^ 2)
D47stats$D47res_York <- D47stats$D47_mean - predict(D47m_York, newdata = newdat_York, se.fit = TRUE, interval = "none", level = 0.95)$fit
D47stats$D47res_lowT_York <- D47stats$D47_mean - predict(D47m_lowT_York, newdata = newdat_York, se.fit = TRUE, interval = "none", level = 0.95)$fit
D47stats$D47res_poly <- D47stats$D47_mean - predict(D47m_poly_MC, newdata = newdat_York, se.fit = TRUE, interval = "none", level = 0.95)$fit
D47stats$D47res_Anderson <- D47stats$D47_mean - (0.0391 * 10 ^ 6 / (D47stats$Temp + 273.15) ^ 2 + 0.154)
D47stats$D47res_Meinicke <- D47stats$D47_mean - (0.0397 * 10 ^ 6 / (D47stats$Temp + 273.15) ^ 2 + 0.1518)
D47stats$D47res_Guo_cc <- D47stats$D47_mean - (((-3.33040 * 10 ^ 9 / (D47stats$Temp + 273.15) ^ 4 + 2.32415 * 10 ^ 7 / (D47stats$Temp + 273.15) ^ 3 - 2.91282 * 10 ^ 3 / (D47stats$Temp + 273.15) ^ 2 - 5.54042 / (D47stats$Temp + 273.15) + 0.23252 + 0.268 - 0.232) - ETH1_GuoCDES) * (ETH1_ICDES-ETH3_ICDES)/(ETH1_GuoCDES-ETH3_GuoCDES) + ETH1_ICDES) * 1.035
D47stats$D47res_Guo_ar <- D47stats$D47_mean - (((-3.43068 * 10 ^ 9 / (D47stats$Temp + 273.15) ^ 4 + 2.35766 * 10 ^ 7 / (D47stats$Temp + 273.15) ^ 3 - 8.06003 * 10 ^ 2 / (D47stats$Temp + 273.15) ^ 2 - 6.90300 / (D47stats$Temp + 273.15) + 0.22893 + 0.268 - 0.232) - ETH1_GuoCDES) * (ETH1_ICDES-ETH3_ICDES)/(ETH1_GuoCDES-ETH3_GuoCDES) + ETH1_ICDES) * 1.035

newdat_York <- data.frame(x = 10 ^6 / (Aisstats$Temp + 273.15) ^ 2)
Aisstats$D47res_York <- Aisstats$D47_mean - predict(D47m_York, newdata = newdat_York, se.fit = TRUE, interval = "none", level = 0.95)$fit
Aisstats$D47res_lowT_York <- Aisstats$D47_mean - predict(D47m_lowT_York, newdata = newdat_York, se.fit = TRUE, interval = "none", level = 0.95)$fit
Aisstats$D47res_poly <- Aisstats$D47_mean - predict(D47m_poly_MC, newdata = newdat_York, se.fit = TRUE, interval = "none", level = 0.95)$fit
Aisstats$D47res_Anderson <- Aisstats$D47_mean - (0.0391 * 10 ^ 6 / (Aisstats$Temp + 273.15) ^ 2 + 0.154)
Aisstats$D47res_Meinicke <- Aisstats$D47_mean - (0.0397 * 10 ^ 6 / (Aisstats$Temp + 273.15) ^ 2 + 0.1518)
Aisstats$D47res_Guo_cc <- Aisstats$D47_mean - (((-3.33040 * 10 ^ 9 / (Aisstats$Temp + 273.15) ^ 4 + 2.32415 * 10 ^ 7 / (Aisstats$Temp + 273.15) ^ 3 - 2.91282 * 10 ^ 3 / (Aisstats$Temp + 273.15) ^ 2 - 5.54042 / (Aisstats$Temp + 273.15) + 0.23252 + 0.268 - 0.232) - ETH1_GuoCDES) * (ETH1_ICDES-ETH3_ICDES)/(ETH1_GuoCDES-ETH3_GuoCDES) + ETH1_ICDES) * 1.035
Aisstats$D47res_Guo_ar <- Aisstats$D47_mean - (((-3.43068 * 10 ^ 9 / (Aisstats$Temp + 273.15) ^ 4 + 2.35766 * 10 ^ 7 / (Aisstats$Temp + 273.15) ^ 3 - 8.06003 * 10 ^ 2 / (Aisstats$Temp + 273.15) ^ 2 - 6.90300 / (Aisstats$Temp + 273.15) + 0.22893 + 0.268 - 0.232) - ETH1_GuoCDES) * (ETH1_ICDES-ETH3_ICDES)/(ETH1_GuoCDES-ETH3_GuoCDES) + ETH1_ICDES) * 1.035

newdat_York <- data.frame(x = 10 ^6 / (violin_data$Temp + 273.15) ^ 2)
violin_data$D47res_York <- violin_data$D47 - predict(D47m_York, newdata = newdat_York, se.fit = TRUE, interval = "none", level = 0.95)$fit
violin_data$D47res_lowT_York <- violin_data$D47 - predict(D47m_lowT_York, newdata = newdat_York, se.fit = TRUE, interval = "none", level = 0.95)$fit
violin_data$D47res_poly <- violin_data$D47 - predict(D47m_poly_MC, newdata = newdat_York, se.fit = TRUE, interval = "none", level = 0.95)$fit
violin_data$D47res_Anderson <- violin_data$D47 - (0.0391 * 10 ^ 6 / (violin_data$Temp + 273.15) ^ 2 + 0.154)
violin_data$D47res_Meinicke <- violin_data$D47 - (0.0397 * 10 ^ 6 / (violin_data$Temp + 273.15) ^ 2 + 0.1518)
violin_data$D47res_Guo_cc <- violin_data$D47 - (((-3.33040 * 10 ^ 9 / (violin_data$Temp + 273.15) ^ 4 + 2.32415 * 10 ^ 7 / (violin_data$Temp + 273.15) ^ 3 - 2.91282 * 10 ^ 3 / (violin_data$Temp + 273.15) ^ 2 - 5.54042 / (violin_data$Temp + 273.15) + 0.23252 + 0.268 - 0.232) - ETH1_GuoCDES) * (ETH1_ICDES-ETH3_ICDES)/(ETH1_GuoCDES-ETH3_GuoCDES) + ETH1_ICDES) * 1.035
violin_data$D47res_Guo_ar <- violin_data$D47 - (((-3.43068 * 10 ^ 9 / (violin_data$Temp + 273.15) ^ 4 + 2.35766 * 10 ^ 7 / (violin_data$Temp + 273.15) ^ 3 - 8.06003 * 10 ^ 2 / (violin_data$Temp + 273.15) ^ 2 - 6.90300 / (violin_data$Temp + 273.15) + 0.22893 + 0.268 - 0.232) - ETH1_GuoCDES) * (ETH1_ICDES-ETH3_ICDES)/(ETH1_GuoCDES-ETH3_GuoCDES) + ETH1_ICDES) * 1.035

# Calculate values for calibrations relative to regressions through our dataset
D47m_York_result_res <- D47m_York_result - D47m_York_result$fit
D47m_York_result_res$x <- D47m_York_result_res$x + D47m_York_result$fit
D47m_York_result_res$Anderson <- Anderson21$D47 - D47m_York_result$fit
D47m_York_result_res$Meinicke <- MeinickeICDES$D47 - D47m_York_result$fit
D47m_York_result_res$Guo_cc <- Guo09$D47_cc - D47m_York_result$fit
D47m_York_result_res$Guo_ar <- Guo09$D47_ar - D47m_York_result$fit

D47m_lowT_York_result_res <- D47m_lowT_York_result - D47m_lowT_York_result$fit
D47m_lowT_York_result_res$x <- D47m_lowT_York_result_res$x + D47m_lowT_York_result$fit
D47m_lowT_York_result_res$Anderson <- Anderson21$D47[1:1001] - D47m_lowT_York_result$fit
D47m_lowT_York_result_res$Meinicke <- MeinickeICDES$D47[1:1001] - D47m_lowT_York_result$fit
D47m_lowT_York_result_res$Guo_cc <- Guo09$D47_cc[1:1001] - D47m_lowT_York_result$fit
D47m_lowT_York_result_res$Guo_ar <- Guo09$D47_ar[1:1001] - D47m_lowT_York_result$fit

D47m_poly_MC_result_res <- D47m_poly_MC_result - D47m_poly_MC_result$fit
D47m_poly_MC_result_res$x <- D47m_poly_MC_result_res$x + D47m_poly_MC_result$fit
D47m_poly_MC_result_res$Anderson <- Anderson21$D47 - D47m_poly_MC_result$fit
D47m_poly_MC_result_res$Meinicke <- MeinickeICDES$D47 - D47m_poly_MC_result$fit
D47m_poly_MC_result_res$Guo_cc <- Guo09$D47_cc - D47m_poly_MC_result$fit
D47m_poly_MC_result_res$Guo_ar <- Guo09$D47_ar - D47m_poly_MC_result$fit

# Export summary of regression residuals
# write.csv(Aisstats, "<path>/Arctica_dataset_propagated_stats.csv")
# write.csv(D47stats, "<path>/Aragonite_dataset_propagated_stats.csv")

# Plot of residuals with respect to regressions (Figure 3)
source("07_Aragonite_residual_plot.r")

# Prepare summary of calibration offsets
calibration_offset <- data.frame(D47_offset = c(dat$D47res_Anderson[which(dat$type == "bivalve" & (dat$Analysis == "this study" | dat$Analysis == "Bernasconi18"))],
        dat$D47res_Meinicke[which(dat$type == "bivalve" & (dat$Analysis == "this study" | dat$Analysis == "Bernasconi18"))],
        dat$D47res_Guo_cc[which(dat$type == "bivalve" & (dat$Analysis == "this study" | dat$Analysis == "Bernasconi18"))],
        dat$D47res_Guo_ar[which(dat$type == "bivalve" & (dat$Analysis == "this study" | dat$Analysis == "Bernasconi18"))]),
    D47_SD = rep(dat$D47_SD[which(dat$type == "bivalve" & (dat$Analysis == "this study" | dat$Analysis == "Bernasconi18"))], 4),
    Calibration = c(rep("Anderson et al., 2021", length(dat$D47res_Meinicke[which(dat$type == "bivalve" & (dat$Analysis == "this study" | dat$Analysis == "Bernasconi18"))])),
        rep("Meinicke et al., 2020", length(dat$D47res_Meinicke[which(dat$type == "bivalve" & (dat$Analysis == "this study" | dat$Analysis == "Bernasconi18"))])),
        rep("Guo et al., 2009 (calcite)", length(dat$D47res_Meinicke[which(dat$type == "bivalve" & (dat$Analysis == "this study" | dat$Analysis == "Bernasconi18"))])),
        rep("Guo et al., 2009 (aragonite)", length(dat$D47res_Meinicke[which(dat$type == "bivalve" & (dat$Analysis == "this study" | dat$Analysis == "Bernasconi18"))])))
)

# Calculate the temperature equivalent of the calibration offset
mean_Temp <- mean(dat$Temp[which(dat$type == "bivalve" & (dat$Analysis == "this study" | dat$Analysis == "Bernasconi18"))])
mean_D47 <- 0.0391 * 10 ^ 6 / (mean_Temp + 273.13) ^ 2 + 0.154

# Statistics of difference with calibration
Calibration_offset_stats <- calibration_offset %>% # Summarize D47 offset statistics
    group_by(Calibration) %>%
    summarize(
        N = n(), # Calculate the number of modelled values, excluding NA's
        D47_offset_Average = binmeans(x = D47_offset, x_sd = D47_SD, output = "mean"),
        D47_offset_SD = binmeans(x = D47_offset, x_sd = D47_SD, output = "SD"),
        D47_offset_SE = D47_offset_SD / sqrt(N - 1), # Calculate the standard error
        D47_offset_CL95 = qt(0.95, N - 1) * D47_offset_SE # Calculate the 95% confidence level
    ) %>%
    ungroup()

Calibration_offset_stats$Temp_offset_Average <- sqrt(0.0391 * 10 ^ 6 / (mean_D47 - Calibration_offset_stats$D47_offset_Average - 0.154)) - 273.15 - mean_Temp
Calibration_offset_stats$Temp_offset_SD <- sqrt(0.0391 * 10 ^ 6 / (mean_D47 - Calibration_offset_stats$D47_offset_Average - Calibration_offset_stats$D47_offset_SD - 0.154)) - 273.15 - mean_Temp - Calibration_offset_stats$Temp_offset_Average
Calibration_offset_stats$Temp_offset_SE <- sqrt(0.0391 * 10 ^ 6 / (mean_D47 - Calibration_offset_stats$D47_offset_Average - Calibration_offset_stats$D47_offset_SE - 0.154)) - 273.15 - mean_Temp - Calibration_offset_stats$Temp_offset_Average
Calibration_offset_stats$Temp_offset_CL95 <- sqrt(0.0391 * 10 ^ 6 / (mean_D47 - Calibration_offset_stats$D47_offset_Average - Calibration_offset_stats$D47_offset_CL95 - 0.154)) - 273.15 - mean_Temp - Calibration_offset_stats$Temp_offset_Average

# write.csv(Calibration_offset_stats, "<path>/Calibration_offset_stats.csv")

# Plot calibration offsets (Figure 4)
source("08_Calibration_offset_plot.r")


subroutine qtest1(h,i,j,k,x,y,ntot,eps,shdswp,nerror)

# The Lee-Schacter test for the LOP (all points are real,
# i.e. non-ideal).  If the LOP is ***not*** satisfied (i.e. if
# vertex j is inside the circumcircle of vertices h, i, and k) then the
# diagonals should be swapped, i.e. shdswp ("should-swap") is true.
# Called by qtest.

implicit double precision(a-h,o-z)
dimension x(-3:ntot), y(-3:ntot), xt(3), yt(3), indv(3)
integer h
logical shdswp, collin

# The vertices of the quadrilateral are labelled
# h, i, j, k in the anticlockwise direction, h
# being the point of central interest.

# Make sure the quadrilateral is convex, so that
# it makes sense to swap the diagonal.
# call acchk(i,j,k,shdswp,x,y,ntot,eps)
# if(!shdswp) return
#
# 23 July 2011:
# The foregoing test is a load of dingoes' kidneys.  (1) It is
# unnecessary, and (2) it is wrong!  (1) If the LOP is not satisfied
# (the only circumstance under which there should be a swap) then the
# quadrilateral ***must*** be convex, and so swapping can sensibly
# take place.  (2) The vertices i, j, k in will ***always*** be in
# anticlockwise order, since the vertices h, i, j, k of the quadrilateral
# are in such order and i is connected to k, whence j can't be inside
# the triangle ihk.  So the test does nothing.  But then it didn't need
# to do anything.

# Check for collinearity of points h, i and k.
xt(1) = x(h)
yt(1) = y(h)
xt(2) = x(i)
yt(2) = y(i)
xt(3) = x(k)
yt(3) = y(k)
nid = 0  # nid = number of ideal points.
call cross(xt,yt,nid,cprd)
collin = (abs(cprd) < eps) # Does this work???

# If the points are collinear, make sure that they're in the right
# order --- h between i and k.
if(collin) {
# Form the vector u from h to i, and the vector v from h to k,
# and normalize them.
    a  = xt(2) - xt(1)
    b  = yt(2) - yt(1)
    c  = xt(3) - xt(1)
    d  = yt(3) - yt(1)
    c1 = sqrt(a*a+b*b)
    c2 = sqrt(c*c+d*d)
    a  = a/c1
    b  = b/c1
    c  = c/c2
    d  = d/c2
    alpha = a*c+b*d
# If they're not in the right order, bring things to
# a shuddering halt.
    if(alpha>0) {
        call intpr("error detected in qtest1",-1,1,0)
        indv(1) = i
        indv(2) = j
        indv(3) = k
        call intpr("Point being added, h:",-1,h,1)
        call intpr("now, other vertex, nxt:",-1,indv,3)
        call dblepr("Test value:",-1,alpha,1)
        call rexit("Points are collinear but h not between i and k.")
    }
# Collinear, and in the right order; think of this as meaning
# that the circumcircle in question has infinite radius.
    shdswp = .true.
}

# Get the coordinates of vertices h and j.
xh = x(h)
yh = y(h)
xj = x(j)
yj = y(j)

# Find the centre of the circumcircle of vertices h, i, k.
call circen(h,i,k,x0,y0,x,y,ntot,eps,shdswp,nerror)
if(nerror>0) return
if(shdswp) return # The points h, i, and k are colinear, so
                  # the circumcircle has `infinite radius', so
                  # (xj,yj) is definitely inside.

# Check whether (xj,yj) is inside the circle of centre
# (x0,y0) and radius r = dist[(x0,y0),(xh,yh)]

a  = x0-xh
b  = y0-yh
r2 = a*a+b*b
a  = x0-xj
b  = y0-yj
ch = a*a + b*b
if(ch<r2) shdswp = .true.
else shdswp = .false.

return
end


library(drat)
library(dde)
library(odin)

drat::add("mrc-ide")

# beta matrix: random initialisation -----------------------------------------------------
beta.mat <- function (nr_patches) {
  ## beta: positive, non-symmetric matrix of effective contact rates
  ## values are higher on the diagonal (transmission is higher *within*-patch),
  ## values decrease gradually further away from the diagonal (*between*-patch transmission)
  beta <- matrix(0, nrow=nr_patches, ncol=nr_patches)
  for (i in 0:(nr_patches-1)) {
    ## superdiagonal: scale vector s.t. numbers decrease further away from diagonal
    rand.vec <- rnorm(nr_patches-i, 10 * (nr_patches-i)/nr_patches, 2)
    beta[row(beta) == col(beta) - i] <- rand.vec
    ## subdiagonal
    rand.vec <- rnorm(nr_patches-i, 10 * (nr_patches-i)/nr_patches, 2)
    beta[row(beta) == col(beta) - i] <- rand.vec
  }
  return(beta)
}

# mobility matrix: random initialisation -----------------------------------------------------
mob.mat <- function (nr_patches) {
  ## mobility matrix (origin-destination matrix of proportion of population that travels) #TODO trip counts or relative?
  C <- matrix(0, nrow=nr_patches, ncol=nr_patches)
  if (nr_patches > 1) {
    diag(C) <- -sample(1:25, nr_patches, replace=TRUE)
    for (i in 1:nr_patches) {
      C[i, which(C[i, ] == 0)] <- rmultinom(n = 1, size = -C[i,i], prob = rep(1, nr_patches-1))
    }
    C <- C/100
  }
  return(C)
}

# plotting --------------------------------------------------------------------#
plot.pretty <- function(out, nr_patches, what) {

  # plot total densities by disease status --------------------------------------#
  if (what == "total") {
    ## compute total densities by disease status
    S_tot <- rowSums(out$S) / nr_patches
    E_tot <- rowSums(out$E) / nr_patches
    I_tot <- rowSums(out$I) / nr_patches
    R_tot <- rowSums(out$R) / nr_patches

    ## plot total densities by disease status
    par(mfrow=c(1, 1), las=1, omi=c(1,0,0,0), xpd=NA)
    plot( t, S_tot, col="green",
          type="l", xlab="Days", ylab="Densities",
          main="Total densities by disease status")
    lines(t, E_tot, col="orange")
    lines(t, I_tot, col="red")
    lines(t, R_tot, col="blue")
    legend(-8.5, -0.3, title="Disease statuses", horiz=TRUE,
           legend=c("Susceptible", "Exposed", "Infectious", "Recovered"),
           col=c("green", "orange", "red", "blue"), lty=1)
  }

  # plot densities of some patches by disease status ----------------------------#
  if (what == "panels") {
    ## define the plot panels
    if (nr_patches >= 6) {
      mfrow=c(2, 3)
      panels <- as.integer( seq(1, nr_patches, length.out=6))
    } else if (nr_patches >= 4) {
      mfrow=c(2, 2)
      panels <- as.integer( seq(1, nr_patches, length.out=4))
    } else {
      mfrow=c(1, nr_patches)
      panels <- 1:nr_patches
    }
    par(mfrow=mfrow, las=1, omi=c(1,0,0.3,0), xpd=NA)

    ## plot the disease statuses of some patches
    ymax <- max(out$N[, panels])
    for (i in panels) {
      plot (t, out$S[, i], col="green", ylim=c(0, ymax),
            type="l", xlab="Days", ylab="Densities",
            main=paste("Patch ", i))
      lines(t, out$E[, i], col="orange")
      lines(t, out$I[, i], col="red")
      lines(t, out$R[, i], col="blue")
    }
    title("Densities by disease status", outer=TRUE)
    legend(-130, -1.2, title="Disease statuses", horiz=TRUE,
           legend=c("Susceptible", "Exposed", "Infectious", "Recovered"),
           col=c("green", "orange", "red", "blue"), lty=1)
  }

}

SEIR_cont <- odin::odin({
  nr_patches <- user()
  n <- nr_patches

  ## Params
  lambda_prod[ , ] <- beta[i, j] * I[j]
  lambda[] <- sum(lambda_prod[i, ]) # rowSums

  mob_prod[ , ] <- S[i] * C[i, j]
  mob_S[] <- sum(mob_prod[, i])     # colSums
  mob_prod[ , ] <- E[i] * C[i, j]
  mob_E[] <- sum(mob_prod[, i])
  mob_prod[ , ] <- I[i] * C[i, j]
  mob_I[] <- sum(mob_prod[, i])
  mob_prod[ , ] <- R[i] * C[i, j]
  mob_R[] <- sum(mob_prod[, i])

  N[] <- S[i] + E[i] + I[i] + R[i]
  output(N[]) <- TRUE

  ## Derivatives
  deriv(S[]) <- mu - mu*S[i] - S[i]*lambda[i]         + M[1] * mob_S[i]
  deriv(E[]) <- S[i]*lambda[i] - (mu + sigma) * E[i]  + M[2] * mob_E[i]
  deriv(I[]) <- sigma*E[i] - (mu + gamma)*I[i]        + M[3] * mob_I[i]
  deriv(R[]) <- gamma*I[i] - mu*R[i]                  + M[4] * mob_R[i]

  ## Initial conditions
  initial(S[]) <- 1.0 - 1E-6
  initial(E[]) <- 0.0
  initial(I[]) <- 1E-6
  initial(R[]) <- 0.0

  ## parameters
  beta[,] <- user()   # effective contact rate
  sigma   <- 1/3      # rate of breakdown to active disease
  gamma   <- 1/3      # rate of recovery from active disease
  mu      <- 1/10     # background mortality
  C[,]    <- user()   # origin-destination matrix of proportion of population that travels
  M[]     <- user()   # relative migration propensity by disease status

  ## dimensions
  dim(beta)        <- c(n, n)
  dim(C)           <- c(n, n)
  dim(M)           <- 4
  dim(lambda_prod) <- c(n, n)
  dim(lambda)      <- n
  dim(mob_prod)    <- c(n, n)
  dim(mob_S)       <- n
  dim(mob_E)       <- n
  dim(mob_I)       <- n
  dim(mob_R)       <- n
  dim(S)           <- n
  dim(E)           <- n
  dim(I)           <- n
  dim(R)           <- n
  dim(N)           <- n

})

# set seed
set.seed(1)

# SEIR free parameters --------------------------------------------------------#
## total number of patches in the model
nr_patches = 20
## relative migration propensity by disease status (S, E, I, R)
M <- c(1, 0.5, 1, 1)
## matrix of effective contact rates
beta <- beta.mat(nr_patches)
## mobility matrix
C <- mob.mat(nr_patches)

# run SEIR model --------------------------------------------------------------#
mod <- SEIR_cont(nr_patches=nr_patches, beta=beta, C=C, M=M)
t <- seq(0, 50, length.out=50000)
out <- mod$run(t)
out <- mod$transform_variables(out)
# error check -----------------------------------------------------------------#
if ( ! all( abs(rowSums(out$N) - nr_patches) < 1E-10 ) )
  warning("Something went wrong, density is increasing/decreasing!\n")

# plot total densities by disease status --------------------------------------#
plot.pretty(out, nr_patches, "total")

# plot densities of some patches by disease status ----------------------------#
plot.pretty(out, nr_patches, "panels")


erf <- function(x) 2 * pnorm(x * sqrt(2)) - 1

flashwear <- function(size, writecount, x, speed=6) {
  return(0.5*(1+erf(((x*(speed*1000*1000*1000/10)/(size*1000*1000*1000))-writecount)/sqrt(2*((writecount*0.1)**2)))))
}

xl <- c(0, 60000000)

svg('flash-integrity.svg', height=6, width=12)
plot(function(x) { return(flashwear(32, 100000, x)) }, col="green", xlab="", xaxt="n", ylab="", xlim=xl, ylim=c(0,1))
legend("topright", inset=.05, c("32 GB Drive", "64 GB Drive", "128 GB Drive", "256 GB Drive", "10% Threshold"), fill=c("green", "blue", "red", "purple", "black"))
axis(1,c(2628000,7884000,15770000,31540000,94610000,189200000), c("1 month", "3 months", "6 months", "1 year", "3 years", "6 years"))
title(main="Drive Wear After Continuous Writing to Flash Memory at 6Gb/s (w/ 8b/10b Coding)", sub="Average Lifespan of Flash Cell Approximated at 100k Writes", xlab="time elapsed", ylab="device wear")
par(new=TRUE)
plot(function(x) { return(flashwear(64, 100000, x)) }, col="blue", xlab="", xaxt="n", ylab="", yaxt="n", xlim=xl, ylim=c(0,1))
par(new=TRUE)
plot(function(x) { return(flashwear(128, 100000, x)) }, col="red", xlab="", xaxt="n", ylab="", yaxt="n", xlim=xl, ylim=c(0,1))
par(new=TRUE)
plot(function(x) { return(flashwear(256, 100000, x)) }, col="purple", xlab="", xaxt="n", ylab="", yaxt="n", xlim=xl, ylim=c(0,1))
par(new=TRUE)
abline(a=0.1, b=0, col="black", xlab="", xaxt="n", ylab="", yaxt="n", xlim=xl, ylim=c(0,1))
dev.off()

svg('flash-integrity-100000.svg', height=6, width=12)
plot(function(x) { return(flashwear(32, 100000, x)) }, col="green", xlab="", xaxt="n", ylab="", xlim=xl, ylim=c(0,1))
legend("topright", inset=.05, c("32 GB Drive", "64 GB Drive", "128 GB Drive", "256 GB Drive", "10% Threshold"), fill=c("green", "blue", "red", "purple", "black"))
axis(1,c(2628000,7884000,15770000,31540000,94610000,189200000), c("1 month", "3 months", "6 months", "1 year", "3 years", "6 years"))
title(main="Drive Wear After Continuous Writing to Flash Memory at 6Gb/s (w/ 8b/10b Coding)", sub="Average Lifespan of Flash Cell Approximated at 100k Writes", xlab="time elapsed", ylab="device wear")
par(new=TRUE)
plot(function(x) { return(flashwear(64, 100000, x)) }, col="blue", xlab="", xaxt="n", ylab="", yaxt="n", xlim=xl, ylim=c(0,1))
par(new=TRUE)
plot(function(x) { return(flashwear(128, 100000, x)) }, col="red", xlab="", xaxt="n", ylab="", yaxt="n", xlim=xl, ylim=c(0,1))
par(new=TRUE)
plot(function(x) { return(flashwear(256, 100000, x)) }, col="purple", xlab="", xaxt="n", ylab="", yaxt="n", xlim=xl, ylim=c(0,1))
par(new=TRUE)
abline(a=0.1, b=0, col="black", xlab="", xaxt="n", ylab="", yaxt="n", xlim=xl, ylim=c(0,1))
dev.off()

xl <- c(0, 640000000)

svg('flash-integrity-1000000.svg', height=6, width=12)
plot(function(x) { return(flashwear(32, 1000000, x)) }, col="green", xlab="", xaxt="n", ylab="", xlim=xl, ylim=c(0,1))
legend("topright", inset=.05, c("32 GB Drive", "64 GB Drive", "128 GB Drive", "256 GB Drive", "10% Threshold"), fill=c("green", "blue", "red", "purple", "black"))
axis(1,c(2628000,7884000,15770000,31540000,94610000,189200000,378400000,756900000), c("1 month", "3 months", "6 months", "1 year", "3 years", "6 years", "12 years", "24 years"))
title(main="Drive Wear After Continuous Writing to Flash Memory at 6Gb/s (w/ 8b/10b Coding)", sub="Average Lifespan of Flash Cell Approximated at 1M Writes", xlab="time elapsed", ylab="device wear")
par(new=TRUE)
plot(function(x) { return(flashwear(64, 1000000, x)) }, col="blue", xlab="", xaxt="n", ylab="", yaxt="n", xlim=xl, ylim=c(0,1))
par(new=TRUE)
plot(function(x) { return(flashwear(128, 1000000, x)) }, col="red", xlab="", xaxt="n", ylab="", yaxt="n", xlim=xl, ylim=c(0,1))
par(new=TRUE)
plot(function(x) { return(flashwear(256, 1000000, x)) }, col="purple", xlab="", xaxt="n", ylab="", yaxt="n", xlim=xl, ylim=c(0,1))
par(new=TRUE)
abline(a=0.1, b=0, col="black", xlab="", xaxt="n", ylab="", yaxt="n", xlim=xl, ylim=c(0,1))
dev.off()


set.seed(15797, kind="Mersenne-Twister")

maxgenerations = 10
cellcount = 20
offendvalue = FALSE

## Cells are alive if TRUE, dead if FALSE
universe <- c(offendvalue,
              sample( c(TRUE, FALSE), cellcount, replace=TRUE),
              offendvalue)

## List of patterns in which the cell stays alive
stayingAlive <- lapply(list(c(1,1,0),
                            c(1,0,1),
                            c(0,1,0)), as.logical)

## x : length 3 logical vector
## map: list of length 3 logical vectors that map to patterns
##      in which x stays alive
deadOrAlive <- function(x, map) list(x) %in% map

cellularAutomata <- function(x, map) {
    c(x[1], apply(embed(x, 3), 1, deadOrAlive, map=map), x[length(x)])
}

deadOrAlive2string <- function(x) {
    paste(ifelse(x, '#', '_'), collapse="")
}

for (i in 1:maxgenerations) {
    universe <- cellularAutomata(universe, stayingAlive)
    cat(format(i, width=3), deadOrAlive2string(universe), "\n")
}


BASIN_CLIMATE_AVERAGING <- function(climateData) {

	num_site <- 1
	DATA <- climateData
	YEAR <- DATA[,1]
	MONTH <- DATA[,2]
	DAY <- DATA[,3]

	SITE_PRCP <- DATA[,4]
	SITE_TMAX <- DATA[,5]
	SITE_TMIN <- DATA[,6]
	no_leap <- which(DAY!=29 | MONTH!=2)

	PRCP <- SITE_PRCP[no_leap]
	TMAX <- SITE_TMAX[no_leap]
	TMIN <- SITE_TMIN[no_leap]
	TEMP <- (TMAX + TMIN)/2

	#Create Time Set
	YEAR_D <- DATA[no_leap,1]
	MONTH_D <-  DATA[no_leap,2]
	DAY_D <- DATA[no_leap,3]

	allData <- cbind(YEAR_D,MONTH_D,DAY_D,PRCP,TMAX,TMIN,TEMP)

	#MONTHLY VARIABLES
	MONTHLY_DATES <- aggregate(allData[,4],FUN=sum,by=list(allData[,2],allData[,1]))[,1:2]
	MONTHLY_PRCP <- aggregate(allData[,4],FUN=sum,by=list(allData[,2],allData[,1]))[,3]
	MONTHLY_TMAX <- aggregate(allData[,5],FUN=mean,by=list(allData[,2],allData[,1]))[,3]
	MONTHLY_TMIN <- aggregate(allData[,6],FUN=mean,by=list(allData[,2],allData[,1]))[,3]
	MONTHLY_TEMP <- aggregate(allData[,7],FUN=mean,by=list(allData[,2],allData[,1]))[,3]

	PRCP <- MONTHLY_PRCP[1:(length(MONTHLY_PRCP))]
	TMAX <- MONTHLY_TMAX[1:(length(MONTHLY_PRCP))]
	TMIN <- MONTHLY_TMIN[1:(length(MONTHLY_PRCP))]
	TEMP <- MONTHLY_TEMP[1:(length(MONTHLY_PRCP))]

	return(cbind(MONTHLY_DATES,PRCP,TMAX,TMIN,TEMP))

}


require(ggplot2)
require(GGally)
require(VGAM)

dat <- read.table("d:/tobit.csv", header=TRUE, sep=",", row.names="id")

summary(dat)

f <- function(x, var, bw = 15) {
  dnorm(x, mean = mean(var), sd(var)) * length(var)  * bw
}

p <- ggplot(dat, aes(x = apt, fill=prog))

p + stat_bin(binwidth=15) +
  stat_function(fun = f, size = 1,
    args = list(var = dat$apt))

p + stat_bin(binwidth = 1) + stat_function(fun = f, size = 1, args = list(var = dat$apt,
    bw = 1))

cor(dat[, c("read", "math", "apt")])

ggpairs(dat[, c("read", "math", "apt")])

------------------------------------------------------------------------------------------

#Below we run the tobit model, using the vglm function of the VGAM package.

summary(m <- vglm(apt ~ read + math + prog, tobit(Upper = 800), data = dat))

ctable <- coef(summary(m))
pvals <- 2 * pt(abs(ctable[, "z value"]), df.residual(m), lower.tail = FALSE)
cbind(ctable, pvals)

m2 <- vglm(apt ~ read + math, tobit(Upper = 800), data = dat)
(p <- pchisq(2 * (logLik(m) - logLik(m2)), df = 2, lower.tail = FALSE))

b <- coef(m)
se <- sqrt(diag(vcov(m)))

cbind(LL = b - qnorm(0.975) * se, UL = b + qnorm(0.975) * se)

dat$yhat <- fitted(m)[,1]
dat$rr <- resid(m, type = "response")
dat$rp <- resid(m, type = "pearson")[,1]
par(mfcol = c(2, 3))

with(dat, {
  plot(yhat, rr, main = "Fitted vs Residuals")
  qqnorm(rr)
  plot(yhat, rp, main = "Fitted vs Pearson Residuals")
  qqnorm(rp)
  plot(apt, rp, main = "Actual vs Pearson Residuals")
  plot(apt, yhat, main = "Actual vs Fitted")
})

(r <- with(dat, cor(yhat, apt)))
r^2


#' Function that propagates measurement uncertainty through model results
#'
#' Function to propagate combined errors on \code{x} (= \code{Dsam}) and
#' \code{y} (= \code{Osam}) on the modeled X (= \code{D}) and Y
#' (= \code{d18Oc}) values by means of orthogonal projection of uncertainty
#' on \code{x} and \code{y} onto the model curve
#' @param x Vector of \code{x} values of input data
#' @param x_err Vector of uncertainties on \code{x} values
#' @param y Vector of \code{y} values of input data
#' @param y_err Vector of uncertainties on \code{y} values
#' @param X Vector of modeled \code{X} values on which the uncertainty is
#' to be projected
#' @param Y Matrix of modeled \code{X} and \code{Y} values
#' @param MC Number of Monte Carlo simulations to apply for error propagation
#' Default = 1000
#' @return A vector listing the standard deviations of propagated errors
#' propagated on all \code{X} values.
#' @examples
#' # Create dummy data for input
#' x <-  seq(1, 40, 1)
#' x_err <- rep(0.1, 40)
#' y <- sin((2 * pi * (seq(1, 40, 1) - 8 + 30 / 4)) / 30)
#' y_err <- rep(0.1, 40)
#' X <- seq(1.5, 39.5, 1)
#' Y <- cbind(seq(1, 39, 1), 0.9 * sin((2 * pi * (seq(1, 39, 1) - 9 +
#'     25 / 4)) / 25))
#' # Run function
#' result <- mc_err_orth(x, x_err, y, y_err, X, Y, 1000)
#' @export
mc_err_orth <- function(x,
    x_err,
    y,
    y_err,
    X,
    Y,
    MC = 1000){ # Function to propagate combined errors on x and y on the modeled X and Y values by means of orthogonal projection of x and y uncertainty on the model curve

    xmat <- matrix(rnorm(MC * length(x)), nrow = length(x)) * x_err + matrix(rep(x, MC), nrow = length(x)) # Create matrix of simulated X values
    ymat <- matrix(rnorm(MC * length(y)), nrow = length(y)) * y_err + matrix(rep(y, MC), nrow = length(y)) # Create matrix of simulated Y values
    Xarray <- sqrt( # create array of the length of vectors connecting each MC simulated x-y pair and each modeled X-Y pair.
        ((outer(xmat, X, FUN = "-") - mean(outer(xmat, X, FUN = "-"))) / sd(outer(xmat, X, FUN = "-"))) ^ 2 + # Square of the normalized difference between MC-simulated X values and modeled D
        ((outer(ymat, Y[, 2], FUN = "-") - mean(outer(ymat, Y[, 2], FUN = "-"))) / sd(outer(ymat, Y[, 2], FUN = "-"))) ^ 2 # Square of the normalized difference between MC-simulated y values and modeled Y values
    )
    posmat <- apply(Xarray, c(1,2), which.min) # For each MC-simulated x-y pair, find the position of the closest model value

    Xsimmat <- matrix(X[posmat], nrow = length(x)) # Find the X value that belongs to each position in posmat
    X_comb <- apply(Xsimmat, 1, mean) # calculate the mean value in X domain resulting from orthogonal projection of errors on X and Y from variability within the X values
    Ysimmat <- matrix(Y[posmat, 2], nrow = length(y)) # Find the Y value that belongs to each position in posmat
    Y_comb <- approx( # Interpolate modeled temperature values to positions along the record.
            x = X,
            y = Y[, 2],
            xout = X_comb,
            method = "linear",
            rule = 2
        )
    # Y_comb <- apply(Ysimmat, 1, mean) # calculate the mean value in Y domain resulting from orthogonal projection of errors on X and Y from variability within the X values
    X_err_comb <- apply(Xsimmat, 1, sd) # calculate the standard deviation in X domain resulting from orthogonal projection of errors on X and Y from variability within the X values
    Y_err_comb <- apply(Ysimmat, 1, sd) # calculate the standard deviation in Y domain resulting from orthogonal projection of errors on X and Y from variability within the X values
    result <- data.frame(
        X = X_comb,
        X_err = X_err_comb,
        Y = Y_comb$y,
        Y_err = Y_err_comb
    )
    return(result)
}


subroutine binsrt(x,y,rw,npd,ind,rind,tx,ty,ilst,nerror)
# Sort the data points into bins.
# Called by master.

implicit double precision(a-h,o-z)
dimension x(npd), y(npd), tx(npd), ty(npd)
integer rind(npd)
dimension ind(npd), ilst(npd)
dimension rw(4)

nerror = -1
kdiv   = 1+dble(npd)**0.25 # Round high.
xkdiv  = dble(kdiv)

# Dig out the corners of the rectangular window.
xmin = rw(1)
xmax = rw(2)
ymin = rw(3)
ymax = rw(4)

w = xmax-xmin
h = ymax-ymin

# Number of bins is to be approx. sqrt(npd); thus number of subdivisions
# on each side of rectangle is approx. npd**(1/4).
dw  = w/xkdiv
dh  = h/xkdiv

# The width of each bin is dw; the height is dh.  We shall move across
# the rectangle from left to right, then up, then back from right to
# left, then up, ....  Note that kx counts the divisions from the left,
# ky counts the divisions from the bottom; kx is incremented by ink, which
# is +/- 1 and switches sign when ky is incremented; ky is always
# incremented by 1.
kx   = 1
ky   = 1
ink  = 1
k    = 0
do i = 1,npd { ilst(i) = 0 } # Keeps a list of those points already added
while(ky<=kdiv) {            # to the new list.
        do i = 1,npd {
                if(ilst(i)==1) next  # The i-th point has already been added
                                     # to the new list.
                # If the i-th point is in the current bin, add it to the list.
                xt = x(i)
                yt = y(i)
                ix = 1+(xt-xmin)/dw
                if(ix>kdiv) ix = kdiv
                jy = 1+(yt-ymin)/dh
                if(jy>kdiv) jy = kdiv
                if(ix==kx&jy==ky) {
                        k = k+1
                        ind(i)  = k  # Index i is the pos'n. of (x,y) in the
                        rind(k) = i  # old list; k is its pos'n. in the new one.
                        tx(k)   = xt
                        ty(k)   = yt
                        ilst(i) = 1  # Cross the i-th point off the old list.
                }
        }
        # Move to the next bin.
        kc = kx+ink
        if((1<=kc)&(kc<=kdiv)) kx = kc
        else {
                ky  = ky+1
                ink = -ink
        }
}

# Check that all points from old list have been added to the new,
# with no spurious additions.
if(k!=npd) {
	nerror = 2
	return
}

# Copy the new sorted vector back on top of the old ones.
do i = 1,npd {
        x(i)   = tx(i)
        y(i)   = ty(i)
}

return
end


# HPD - Highest Posterior Density (HPD) Interval

#-----8<-----
# Using boa package
ans <- boa.hpd(resultado.final[,i], alpha = 0.05)
write.csv2( ans , paste("HPD ",i,".csv", sep=""))
print( ans )

#-----8<-----

# [1] "Computing HPD Interval for NR.LGA"
# Lower Bound Upper Bound
# 0.08768426  0.09717933
# [1] "Computing HPD Interval for NR.PE"
# Lower Bound Upper Bound
# 0.02852109  0.06567756
# [1] "Computing HPD Interval for NR.CS"
# Lower Bound Upper Bound
# 0.09675619  0.28645520
# [1] "Computing HPD Interval for WHO.LGA"
# Lower Bound Upper Bound
# 0.08496027  0.09427048
# [1] "Computing HPD Interval for WHO.PE"
# Lower Bound Upper Bound
# 0.02790777  0.06400733
# [1] "Computing HPD Interval for WHO.CS"
# Lower Bound Upper Bound
# 0.09531015  0.28389315
# [1] "Computing HPD Interval for IADPSG.LGA"
# Lower Bound Upper Bound
# 0.08278797  0.09268037
# [1] "Computing HPD Interval for IADPSG.PE"
# Lower Bound Upper Bound
# 0.02743658  0.06309003
# [1] "Computing HPD Interval for IADPSG.CS"
# Lower Bound Upper Bound
# 0.09516766  0.28336441

Simulation Gestational Diabetes WHO/HPD_NR_WHO_IADPSG.r


#########################################################################################################################################
sceDefaults <- function()
    list(ncomplex = 5, ## number of complexes
         cce.iter = NA, ## number of iteration in inner loop (CCE algorithm)
         fnscale = 1, ## function scaling factor (set to -1 for maximisation)
         elitism = 1, ## controls amount of weighting in sampling towards the better parameter sets
         initsample = "latin", ## sampling scheme for initial values -- "latin" or "random"
         reltol = 1e-5, ## convergence threshold: relative improvement factor required in an SCE iteration
         tolsteps = 7, ## number of iterations within reltol to confirm convergence
         maxit = 10000, ## maximum number of iterations
         maxeval = Inf, ## maximum number of function evaluations
         maxtime = Inf, ## maximum duration of optimization in seconds
         returnpop = FALSE, ## whether to return populations from all iterations
         trace = 0, ## level of user feedback
         REPORT = 1) ## number of iterations between reports when trace >= 1

SCEoptim <- function(FUN, par, ...,
                lower = -Inf, upper = Inf,
                control = list())
{
    FUN <- match.fun(FUN)
    stopifnot(is.numeric(par))
    stopifnot(length(par) > 0)
    stopifnot(is.numeric(lower))
    stopifnot(is.numeric(upper))
    ## allow `lower` or `upper` to apply to all parameters
    if (length(lower) == 1)
        lower <- rep(lower, length = length(par))
    if (length(upper) == 1)
        upper <- rep(upper, length = length(par))
    stopifnot(length(lower) == length(par))
    stopifnot(length(upper) == length(par))

    ## determine number of variables to be optimized
    NDIM <- length(par)

    ## update default options with supplied options
    stopifnot(is.list(control))
    control <- modifyList(sceDefaults(), control)
    isValid <- names(control) %in% names(sceDefaults())
    if (any(!isValid))
        stop("unrecognised options: ",
             toString(names(control)[!isValid]))

    returnpop <- control$returnpop
    trace <- control$trace
    nCOMPLEXES <- control$ncomplex
    CCEITER <- control$cce.iter
    MAXIT <- control$maxit
    MAXEVAL <- control$maxeval

    ## recommended number of CCE steps in Duan et al 1994:
    if (is.na(CCEITER))
        CCEITER <- 2 * NDIM + 1

    if (is.finite(MAXEVAL)) {
        ## upper bound on number of iterations to reach MAXEVAL
        MAXIT <- min(MAXIT, ceiling(MAXEVAL / (nCOMPLEXES * CCEITER)))
    }

    ## define number of points in each complex
    nPOINTS_COMPLEX <- 2 * NDIM + 1

    ## define number of points in each simplex
    nPOINTS_SIMPLEX <- NDIM+1

    ## define total number of points
    nPOINTS <- nCOMPLEXES * nPOINTS_COMPLEX

    ## initialize counters
    funevals <- 0

    costFunction <- function(FUN, par, ...)
    {
        ## check lower and upper bounds
        i <- which(par < lower)
        if (any(i)) {
            i <- i[1]
            return( 1e12 + (lower[i] - par[i]) * 1e6 )
        }
        i <- which(par > upper)
        if (any(i)) {
            i <- i[1]
            return( 1e12 + (par[i] - upper[i]) * 1e6 )
        }
        funevals <<- funevals + 1
        result <- FUN(par, ...) * control$fnscale
        if (is.na(result))
            result <- 1e12
        result
    }

    simplexStep <- function(P, FAC)
    {
        ## Extrapolates by a factor FAC through the face of the simplex across from
        ## the highest (i.e. worst) point.
        worst <- nPOINTS_SIMPLEX
        centr <- apply(P[-worst,,drop=FALSE], 2, mean)
        newpar <- centr*(1-FAC) + P[worst,]*FAC
        newpar
    }

    ## initialize population matrix
    POPULATION <- matrix(as.numeric(NA), nrow = nPOINTS, ncol = NDIM)
    if (!is.null(names(par)))
        colnames(POPULATION) <- names(par)
    POP.FITNESS <- numeric(length = nPOINTS)
    POPULATION[1,] <- par

    ## generate initial parameter values by random uniform sampling
    finitelower <- ifelse(is.infinite(lower), -(abs(par)+2)*5, lower)
    finiteupper <- ifelse(is.infinite(upper), +(abs(par)+2)*5, upper)
    if (control$initsample == "latin") {
        for (i in 1:NDIM) {
            tmp <- seq(finitelower[i], finiteupper[i], length = nPOINTS-1)
            tmp <- jitter(tmp, factor = 2)
            tmp <- pmax(finitelower[i], pmin(finiteupper[i], tmp))
            POPULATION[-1,i] <- sample(tmp)
        }
    } else {
        for (i in 1:NDIM)
            POPULATION[-1,i] <- runif(nPOINTS-1, finitelower[i], finiteupper[i])
    }

    ## only store all iterations if requested -- could be big!
    if (!is.finite(MAXIT)) {
        MAXIT <- 10000
        warning("setting maximum iterations to 10000")
    }
    if (returnpop) {
        POP.ALL <- array(as.numeric(NA), dim = c(nPOINTS, NDIM, MAXIT))
        if (!is.null(names(par)))
            dimnames(POP.ALL)[[2]] <- names(par)
    }
    POP.FIT.ALL <- matrix(as.numeric(NA), ncol = nPOINTS, nrow = MAXIT)
    BESTMEM.ALL <- matrix(as.numeric(NA), ncol = NDIM, nrow = MAXIT)
    if (!is.null(names(par)))
        colnames(BESTMEM.ALL) <- names(par)

    ## the output object
    obj <- list()
    class(obj) <- c("SCEoptim", class(obj))
    obj$call <- match.call()
    obj$control <- control

    EXITFLAG <- NA
    EXITMSG <- NULL

    ## initialize timer
    tic <- as.numeric(Sys.time())
    toc <- 0

    ## calculate cost for each point in initial population
    for (i in 1:nPOINTS)
        POP.FITNESS[i] <- costFunction(FUN, POPULATION[i,], ...)

    ## sort the population in order of increasing function values
    idx <- order(POP.FITNESS)
    POP.FITNESS <- POP.FITNESS[idx]
    POPULATION <- POPULATION[idx,,drop=FALSE]

    ## store one previous iteration only
    POP.PREV <- POPULATION
    POP.FIT.PREV <- POP.FITNESS

    if (returnpop) {
        POP.ALL[,,1] <- POPULATION
    }
    POP.FIT.ALL[1,] <- POP.FITNESS
    BESTMEM.ALL[1,] <- POPULATION[1,]

    ## store best solution from last two iterations
    prevBestVals <- rep(Inf, control$tolsteps)
    prevBestVals[1] <- POP.FITNESS[1]

    ## for each iteration...
    i <- 0
    while (i < MAXIT) {

        i <- i + 1

        ## The population matrix POPULATION will now be rearranged into complexes.

        ## For each complex ...
        for (j in 1:nCOMPLEXES) {

            ## construct j-th complex from POPULATION

            k1 <- 1:nPOINTS_COMPLEX
            k2 <- (k1-1) * nCOMPLEXES + j

            COMPLEX <- POP.PREV[k2,,drop=FALSE]
            COMPLEX_FITNESS <- POP.FIT.PREV[k2]

            ## Each complex evolves a number of steps according to the competitive
            ## complex evolution (CCE) algorithm as described in Duan et al. (1992).
            ## Therefore, a number of 'parents' are selected from each complex which
            ## form a simplex. The selection of the parents is done so that the better
            ## points in the complex have a higher probability to be selected as a
            ## parent. The paper of Duan et al. (1992) describes how a trapezoidal
            ## probability distribution can be used for this purpose.

            for (k in 1:CCEITER) {

                ## select simplex by sampling the complex

                ## sample points with "trapezoidal" i.e. linear probability
                weights <- rev(ppoints(nPOINTS_COMPLEX))
                ## 'elitism' parameter can give more weight to the better results:
                weights <- weights ^ control$elitism
                LOCATION <- sample(seq(1,nPOINTS_COMPLEX), size = nPOINTS_SIMPLEX,
                                   prob = weights)

                LOCATION <- sort(LOCATION)

                ## construct the simplex
                SIMPLEX <- COMPLEX[LOCATION,,drop=FALSE]
                SIMPLEX_FITNESS <- COMPLEX_FITNESS[LOCATION]

                worst <- nPOINTS_SIMPLEX

                ## generate new point for simplex

                ## first extrapolate by a factor -1 through the face of the simplex
                ## across from the high point,i.e.,reflect the simplex from the high point
                parRef <- simplexStep(SIMPLEX, FAC = -1)
                fitRef <- costFunction(FUN, parRef, ...)

                ## check the result
                if (fitRef <= SIMPLEX_FITNESS[1]) {
                    ## gives a result better than the best point,so try an additional
                    ## extrapolation by a factor 2
                    parRefEx <- simplexStep(SIMPLEX, FAC = -2)
                    fitRefEx <- costFunction(FUN, parRefEx, ...)
                    if (fitRefEx < fitRef) {
                        SIMPLEX[worst,] <- parRefEx
                        SIMPLEX_FITNESS[worst] <- fitRefEx
                        ALGOSTEP <- 'reflection and expansion'
                    } else {
                        SIMPLEX[worst,] <- parRef
                        SIMPLEX_FITNESS[worst] <- fitRef
                        ALGOSTEP <- 'reflection'
                    }
                } else if (fitRef >= SIMPLEX_FITNESS[worst-1]) {
                    ## the reflected point is worse than the second-highest, so look
                    ## for an intermediate lower point, i.e., do a one-dimensional
                    ## contraction
                    parCon <- simplexStep(SIMPLEX, FAC = -0.5)
                    fitCon <- costFunction(FUN, parCon, ...)
                    if (fitCon < SIMPLEX_FITNESS[worst]) {
                        SIMPLEX[worst,] <- parCon
                        SIMPLEX_FITNESS[worst] <- fitCon
                        ALGOSTEP <- 'one dimensional contraction'
                    } else {
                        ## can't seem to get rid of that high point, so better contract
                        ## around the lowest (best) point
                        SIMPLEX <- (SIMPLEX + rep(SIMPLEX[1,], each=nPOINTS_SIMPLEX)) / 2
                        for (k in 2:NDIM)
                            SIMPLEX_FITNESS[k] <- costFunction(FUN, SIMPLEX[k,], ...)
                        ALGOSTEP <- 'multiple contraction'
                    }
                } else {
                    ## if better than second-highest point, use this point
                    SIMPLEX[worst,] <- parRef
                    SIMPLEX_FITNESS[worst] <- fitRef
                    ALGOSTEP <- 'reflection'
                }

                if (trace >= 3) {
                    message(ALGOSTEP)
                }

                ## replace the simplex into the complex
                COMPLEX[LOCATION,] <- SIMPLEX
                COMPLEX_FITNESS[LOCATION] <- SIMPLEX_FITNESS

                ## sort the complex
                idx <- order(COMPLEX_FITNESS)
                COMPLEX_FITNESS <- COMPLEX_FITNESS[idx]
                COMPLEX <- COMPLEX[idx,,drop=FALSE]
            }

            ## replace the complex back into the population
            POPULATION[k2,] <- COMPLEX
            POP.FITNESS[k2] <- COMPLEX_FITNESS
        }

        ## At this point, the population was divided in several complexes, each of which
        ## underwent a number of iteration of the simplex (Metropolis) algorithm. Now,
        ## the points in the population are sorted, the termination criteria are checked
        ## and output is given on the screen if requested.

        ## sort the population
        idx <- order(POP.FITNESS)
        POP.FITNESS <- POP.FITNESS[idx]
        POPULATION <- POPULATION[idx,,drop=FALSE]
        if (returnpop) {
            POP.ALL[,,i] <- POPULATION
        }
        POP.FIT.ALL[i,] <- POP.FITNESS
        BESTMEM.ALL[i,] <- POPULATION[1,]

        curBest <- POP.FITNESS[1]

        ## end the optimization if one of the stopping criteria is met

        prevBestVals <- c(curBest, head(prevBestVals, -1))
        reltol <- control$reltol
        if (all(abs(diff(prevBestVals)) <= reltol * (abs(curBest)+reltol))) {
            EXITMSG <- 'Change in solution over [tolsteps] less than specified tolerance (reltol).'
            EXITFLAG <- 0
        }

        ## give user feedback on screen if requested
        if (trace >= 1) {
            if (i == 1) {
                message(' Nr Iter Nr Fun Eval Current best function Current worst function')
            }
            if ((i %% control$REPORT == 0) || (!is.na(EXITFLAG)))
            {
                message(sprintf(' %5.0f %5.0f %12.6g %12.6g',
                        i, funevals, min(POP.FITNESS), max(POP.FITNESS)))
                if (trace >= 2)
                    message("parameters: ", toString(signif(POPULATION[1,], 3)))
            }
        }

        if (!is.na(EXITFLAG))
            break

        if ((i >= control$maxit) || (funevals >= control$maxeval)) {
            EXITMSG <- 'Maximum number of function evaluations or iterations reached.'
            EXITFLAG <- 1
            break
        }

        toc <- as.numeric(Sys.time()) - tic
        if (toc > control$maxtime) {
            EXITMSG <- 'Exceeded maximum time.'
            EXITFLAG <- 2
            break
        }

        ## go to next iteration
        POP.PREV <- POPULATION
        POP.FIT.PREV <- POP.FITNESS
    }
    if (trace >= 1)
        message(EXITMSG)

    ## return solution
    obj$par <- POPULATION[1,]
    obj$value <- POP.FITNESS[1]
    obj$convergence <- EXITFLAG
    obj$message <- EXITMSG

    ## store number of function evaluations
    obj$counts <- funevals
    ## store number of iterations
    obj$iterations <- i
    ## store the amount of time taken
    obj$time <- toc

    if (returnpop) {
        ## store information on the population at each iteration
        obj$POP.ALL <- POP.ALL[,,1:i]
        dimnames(obj$POP.ALL)[[3]] <- paste("iteration", 1:i)
    }
    obj$POP.FIT.ALL <- POP.FIT.ALL[1:i,]
    obj$BESTMEM.ALL <- BESTMEM.ALL[1:i,]

    obj
}


# This program computes and outputs the Bonferroni-p outliers of a time series generated by a linear model of flux
# against a 2nd degree polynomial of time. The input format is a two column .csv (time, flux) and may include
# restrictions on the indices to use to account for jumps in flux. After finding Bonferroni adjusted outliers at the
# alpha = .05 level the element is removed and the test is conducted again with a new model. When the program is complete
# a separate an ID line is printed into a separate file

# The output is placed in a .csv file with two columns (outlier_time, outlier_bonferroniP)

args = commandArgs(trailingOnly=TRUE)
file_in <- args[1]
first_index <- args[2]
last_index <- args[3]
file_out <- args[4]
file_lock <- args[5]

data = read.csv(file_in, header=FALSE)
time <- data$V1[first_index:last_index]
flux <- data$V2[first_index:last_index]
time_squared <- time * time

done <- FALSE
sink(file_out)
while(!done) {
	model = lm(flux ~ time + time_squared)

	# This is a terrible way to print out the label and know the index
	# TODO: Figure out how to get the index out of each test$bonf.p[i] value
	test_times = car::outlierTest(model, label=time)

	# TODO: Figure out in what format these elements are stored
	name <- names(test_times$bonf.p[1])
	value <- test_times$bonf.p[1]

	if(!is.na(name) & value < 1) {
		cat(name, ",", value, "\n", sep="", labels="")

		target_time <- as.integer(name)
		index_to_remove <- match(c(target_time), time)
		time <- time[-c(index_to_remove)]
		flux <- flux[-c(index_to_remove)]
		time_squared <- time_squared[-c(index_to_remove)]
	}
	else {
		done = TRUE
	}
}

sink(file_lock)
cat("locked", "\n")