# # This script was written by nicolas m. roberts, primarily using the geologyGeometry library of functions, written by Joshua R. Davis.
# # if you incounter bugs in the code, please inform nick at nmroberts@wisc.edu

### PRELIMINARY WORK ####

# FOR MAC: Set the working directory.
setwd("~/Desktop/20170620geologyGeometry")

# [!!!] FOR WINDOWS: Set the working directory.
# setwd("C:/users/[Insert user name]/Desktop/20170620geologyGeometry")

# Load the necessary R libraries.
source("library/all.R")

# Load some custom functions.
source("JSG_statsFunctions.r")

# [!!!] Markov chain Monte Carlo and Kamb contouring in equal volume plots require C compiler. Skip MCMC and equal volume Kamb lines if you do not wish to install C. Load the necessary library
# source("libraryC/all.R")

#==========================LOAD THE DATA========================================

# 1) Foliation only
Fols <- geoDataFromFile("data/Fols_WestMt.csv")

# Plot foliation locations in map view
plot(Fols$easting, Fols$northing, xlab = "Easting (meters)", ylab = "Northing (meters)")

# Check how many measurments there are
nrow(Fols)

#————————————————————————————————————————————————————————————

# 2) Foliation-lineation pairs
Follins <- geoDataFromFile("data/Follins_WestMt.csv")

# Plot foliation-lineation locations in map view
plot(
    Follins$easting,
    Follins$northing,
    xlab = "Easting (meters)",
    ylab = "Northing (meters)"
)

# Check how many measurements there are
nrow(Follins)

#==========================PART I: DIRECTIONAL STATISTICS ON FOLIATIONS========================================
#==========================DEFINE GEOGRAPHIC DOMAINS FOR FOLIATION-ONLY DATA=================================

#(After Braudy et al., 2017)

# Define the geographic criteria that defines the different domains. The numbers are UTM coordinates
Fols_northCrit <- Fols$northing > 4922736
Fols_centerCrit <- Fols$northing < 4922736 & Fols$northing > 4919205
Fols_southCrit <- Fols$northing < 4919205

# Create a new column in the dataframe in which to store the domain information
Fols$domain <- replicate(nrow(Fols), 1)

# Classify the foliation-only dataset by domain
Fols$domain[Fols_northCrit] <- 1
Fols$domain[Fols_centerCrit] <- 2
Fols$domain[Fols_southCrit] <- 3

# Plot the locations of the foliation-only data in map view, each domain a different color.
plot(
    x = Fols$easting,
    y = Fols$northing,
    xlab = "Easting (meters)",
    ylab = "Northing (meters)",
    col = hues(Fols$domain),
    pch = 19
)

# Return the number of datapoints in each domain.
length(Fols$domain[Fols_northCrit])
length(Fols$domain[Fols_centerCrit])
length(Fols$domain[Fols_southCrit])

#==========================DEFINE GEOGRAPHIC DOMAINS FOR FOLIATION-LINEATION DATA========================================

# (After Braudy et al., 2017)

# Define the geographic criteria that defines the different domains
Follins_northCrit <-  Follins$northing > 4922736
Follins_centerCrit <- Follins$northing < 4922736 & Follins$northing > 4919205
Follins_southCrit <-  Follins$northing < 4919205

# Create a new column in the dataframe in which to store the domain information
Follins$domain <- replicate(nrow(Follins), 1)

# Classify the foliation-lineation dataset by domain
Follins$domain[Follins_northCrit] <- 1
Follins$domain[Follins_centerCrit] <- 2
Follins$domain[Follins_southCrit] <- 3

# Plot the locations of the foliation-lineation data in map view, each domain a different color.
plot(
    x = Follins$easting,
    y = Follins$northing,
    xlab = "Easting (meters)",
    ylab = "Northing (meters)",
    col = hues(Follins$domain),
    pch = 19
)

# Return the number of datapoints in each domain.
length(Follins$domain[Follins_northCrit])
length(Follins$domain[Follins_centerCrit])
length(Follins$domain[Follins_southCrit])

#==========================FOLIATION-ONLY STATISTCAL TREATMENT========================================

# 1) Some parametric two-sample tests. The null hypothesis for all tests is that the two domains being tested come from the same population.

# Three Wellner tests (Wellner, 1979), one for each pair of domains. Each test is based on 10,000 permutations. This tests not only if the samples come from the populations with the same mean, but also with the same dispersion.
lineWellnerInference(Fols$pole[Fols_northCrit], Fols$pole[Fols_southCrit], 10000)
lineWellnerInference(Fols$pole[Fols_northCrit], Fols$pole[Fols_centerCrit], 10000)
lineWellnerInference(Fols$pole[Fols_centerCrit], Fols$pole[Fols_southCrit], 10000)

# Three Watson tests that assume large sample size (Mardia and Jupp, 2000), one for each pair of domains.
lineLargeMultiSampleWatsonInference(list(Fols$pole[Fols_northCrit],  Fols$pole[Fols_southCrit]))
lineLargeMultiSampleWatsonInference(list(Fols$pole[Fols_northCrit],  Fols$pole[Fols_centerCrit]))
lineLargeMultiSampleWatsonInference(list(Fols$pole[Fols_centerCrit], Fols$pole[Fols_southCrit]))

# Three Watson tests that assume tightly concentrated datasets (Mardia and Jupp, 2000), one for each pair of domains.
lineConcentratedMultiSampleWatsonInference(list(Fols$pole[Fols_northCrit],  Fols$pole[Fols_southCrit]))
lineConcentratedMultiSampleWatsonInference(list(Fols$pole[Fols_northCrit],  Fols$pole[Fols_centerCrit]))
lineConcentratedMultiSampleWatsonInference(list(Fols$pole[Fols_centerCrit], Fols$pole[Fols_southCrit]))

#————————————————————————————————————————————————————————————

# 2) Non-parametric bootstrapping

# Perform the bootstrapping routine for each domain. Each bootstrapped dataset is based on 10,000 iterations.
Fols_northBoots <-  lineBootstrapInference(Fols$pole[Fols_northCrit], 10000, numPoints = 50)
Fols_centerBoots <- lineBootstrapInference(Fols$pole[Fols_centerCrit], 10000, numPoints = 50)
Fols_southBoots <-  lineBootstrapInference(Fols$pole[Fols_southCrit], 10000, numPoints = 50)

# Plot data for each domain. Northern (red), central (green), southern (blue)
lineEqualAreaPlotThree(
                       Fols$pole[Fols_northCrit],
                       Fols$pole[Fols_centerCrit],
                       Fols$pole[Fols_southCrit]
)

# Plot the bootstrapped mean clouds for each domain.  Northern (red), central (green), southern (blue)
lineEqualAreaPlotThree(
    Fols_northBoots$bootstraps,
    Fols_centerBoots$bootstraps,
    Fols_southBoots$bootstraps
)

# Plot the bootstrapped mean with 95% confidence ellipses superimposed.  Northern (red), central (green), southern (blue)
lineEqualAreaPlotThree(
    list(Fols_northBoots$center),
    list(Fols_centerBoots$center),
    list(Fols_southBoots$center),
    curves = list(
        Fols_northBoots$points,
        Fols_centerBoots$points,
        Fols_southBoots$points
    )
)

#————————————————————————————————————————————————————————————

# 3) Compute the rotation between the north and south domains.

# Create empty lists to store data
northSouthDiff <- list()

# Assign variables for the orientations of all bootstrapped means.
northB <- Fols_northBoots$bootstraps
southB <- Fols_southBoots$bootstraps

# Calculate the smallest possible rotations that bring means from the northern bootstrap cloud to the southern bootstrap clouds.
count = 1
for (i in 1:300) {
    for (n in i:300) {
        northSouthDiff$rotation[[count]] = rotSmallestRotationFromTwoLines(northB[[i]], southB[[n]])
        if (n < 90000) {
            count = count + 1
        }
    }
}

# Display the raw results of the preceting for loop
northSouthDiff

# Plot these rotations in an equal volume plot
oriEqualVolumePlot(
                   northSouthDiff$rotation,
                   group = oriLineInPlaneGroup,
                   simplePoints = TRUE
)

# Compute the axis and rotation amount from all the rotations
Fols_angleAxis <- lapply(northSouthDiff$rotation, function(s) rotAxisAngleFromMatrix(s))

#Identify the rotation axes
rotationAxes <- lapply(Fols_angleAxis, function(s) c(s[1], s[2], s[3]))

rotationAxisMean <- lineProjectedMean(rotationAxes)
inf <- rayMahalanobisInference(rotationAxes, rotationAxisMean, numPoints=100)

# Plot the rotation axes in an equal area plot
lineEqualAreaPlot(
                  rotationAxes,
                  shapes = '.',
)

# Plot the rotation axis mean orientation with the 95% confidence ellipse
lineEqualAreaPlot(
                  list(inf$center),
                  curves = list(inf$points)
)

# Plot a histogram of rotation amount between the northern domain and the southern domain, in degrees.
hist(
     as.numeric(lapply(Fols_angleAxis, function(s) s[4] * 180 / pi)),
     30,
     xlab = "Angular Distance (degrees)",
     ylab = "Frequency",
     main = "Angular distances, Northern to Southern"
)

# Compute the mean and 1-sigma standard deviation of the rotation amount, in degrees
mean(sapply(Fols_angleAxis, function(s) s[4] * 180 / pi))
sd(sapply(Fols_angleAxis, function(s) s[4] * 180 / pi))

# Compute the mean trend and plunge in degrees
Fols_axes <- lapply(Fols_angleAxis, function(s) c(s[1], s[2], s[3]))
Fols_meanAxisDeg <- geoTrendPlungeDegFromCartesian(lower(lineProjectedMean(Fols_axes)))

#Print the mean axis of rotation, in trend and plunge
Fols_meanAxisDeg

#==========================FOLIATIONS FROM FOLIATION-LINEATION PAIRS STATISTICAL TREATMENT========================================

#### FOLIATIONS FROM FOLIATION-LINEATION PAIRS STATISTICAL TREATMENT

# 1) Some parametric two-sample tests.

# Three Wellner tests (Wellner, 1979), one for each pair of domains. Each test is based on 10,000 permutations.
lineWellnerInference(Follins$pole[Follins_northCrit],  Follins$pole[Follins_southCrit], 10000)
lineWellnerInference(Follins$pole[Follins_northCrit],  Follins$pole[Follins_centerCrit], 10000)
lineWellnerInference(Follins$pole[Follins_centerCrit], Follins$pole[Follins_southCrit], 10000)

# Three Watson tests that assume large sample size (Mardia and Jupp, 2000), one for each pair of domains.
lineLargeMultiSampleWatsonInference(list(Follins$pole[Follins_northCrit], Follins$pole[Follins_southCrit]))
lineLargeMultiSampleWatsonInference(list(Follins$pole[Follins_northCrit], Follins$pole[Follins_centerCrit]))
lineLargeMultiSampleWatsonInference(list(Follins$pole[Follins_centerCrit], Follins$pole[Follins_southCrit]))

# Three Watson tests that assume tightly concentrated datasets (Mardia and Jupp, 2000), one for each pair of domains.
lineConcentratedMultiSampleWatsonInference(list(Follins$pole[Follins_northCrit], Follins$pole[Follins_southCrit]))
lineConcentratedMultiSampleWatsonInference(list(Follins$pole[Follins_northCrit], Follins$pole[Follins_centerCrit]))
lineConcentratedMultiSampleWatsonInference(list(Follins$pole[Follins_centerCrit], Follins$pole[Follins_southCrit]))

#————————————————————————————————————————————————————————————

# 2) Non-parametric bootstrapping

# Perform the bootstrapping routine for each domain. Each bootstrapped dataset is based on 10,000 iterations.
FollinFols_northBoots <-  lineBootstrapInference(Follins$pole[Follins_northCrit], 10000, numPoints = 50)
FollinFols_centerBoots <- lineBootstrapInference(Follins$pole[Follins_centerCrit], 10000, numPoints = 50)
FollinFols_southBoots <-  lineBootstrapInference(Follins$pole[Follins_southCrit], 10000, numPoints = 50)

# Plot data for each domain. Northern (red), central (green), southern (blue)
lineEqualAreaPlotThree(
                       Follins$pole[Follins_northCrit],
                       Follins$pole[Follins_centerCrit],
                       Follins$pole[Follins_southCrit]
)

# Plot the bootstrapped mean clouds for each domain. Northern (red), central (green), southern (blue)
lineEqualAreaPlotThree(
                       FollinFols_northBoots$bootstraps,
                       FollinFols_centerBoots$bootstraps,
                       FollinFols_southBoots$bootstraps
)

# Plot the bootstrapped mean clouds with 95% confidence ellipses superimposed. Northern (red), central (green), southern (blue)
lineEqualAreaPlotThree(
                       list(FollinFols_northBoots$center),
                       list(FollinFols_centerBoots$center),
                       list(FollinFols_southBoots$center),
                       curves = list(
                                     FollinFols_northBoots$points,
                                     FollinFols_centerBoots$points,
                                     FollinFols_southBoots$points
                                     )
)

#————————————————————————————————————————————————————————————

# 3) Compute the rotation between the north and south domains.

# Create empty lists to store data
Follins_northSouthDif <- list()

# Assign variables for the orientations of all bootstrapped means.
Follins_northB <- FollinFols_northBoots$bootstraps
Follins_southB <- FollinFols_southBoots$bootstraps

# Calculate the smallest possible rotations that bring means from the northern bootstrap cloud to the southern bootstrap clouds.
count = 1
for (i in 1:100) {
    for (n in i:100) {
        Follins_northSouthDif$rotation[[count]] = rotSmallestRotationFromTwoLines(Follins_northB[[i]], Follins_southB[[n]])
        if (n < 1000) {
            count = count + 1
        }
    }
}

# Display the raw results of the preceting for loop
Follins_northSouthDif

# Plot these rotations in an equal volume plot
oriEqualVolumePlot(
                   Follins_northSouthDif$rotation,
                   group = oriLineInPlaneGroup,
                   simplePoints = TRUE
)

# Compute the axis and rotation amount from all the rotations
Follins_angleAxis <- lapply(Follins_northSouthDif$rotation, function(s) rotAxisAngleFromMatrix(s))

# Plot the rotation axes in an equal area plot
lineEqualAreaPlot(lapply(Follins_angleAxis, function(s) c(s[1], s[2], s[3])), shapes = '.')

# Plot a histogram of rotation amount between the northern domain and the southern domain, in degrees.
hist(
     as.numeric(lapply(Follins_angleAxis, function(s)
        s[4] * 180 / pi)),
     30,
     xlab = "Angular Distance (degrees)",
     ylab = "Frequency",
     main = "Angular distances, Northern to Southern"
)

# Compute the mean and 1-sigma standard deviation of the rotation amount, in Follins_angleAxisrees
mean(sapply(Follins_angleAxis, function(s) s[4] * 180 / pi))
sd(sapply(Follins_angleAxis, function(s) s[4] * 180 / pi))

# Compute the mean trend and plunge in Follins_angleAxisrees
Follins_axes <- lapply(Follins_angleAxis, function(s) c(s[1], s[2], s[3]))
Follins_meanAxisDeg <- geoTrendPlungeDegFromCartesian(lower(lineProjectedMean(Follins_axes)))

#Print the mean axis of rotation, in trend and plunge
Follins_meanAxisDeg

#==========================COMPARE FOLIATIONS FROM THE TWO DATASETS========================================

# (Foliation-only vs. Foliation-lineation datasets)

# 1) Three plots to compare the foliations of the Fols (Foliation only data set) and Follins (Foliation-lineation dataset) in the northern domain

# Equal area plot of the Fols (cyan) and Follins (red)
lineEqualAreaPlotTwo(Follins$pole[Follins_northCrit], Fols$pole[Fols_northCrit])

# Equal area plot of the bootstrapped means for the Fols (cyan) and Follins (red)
lineEqualAreaPlotTwo(
                     FollinFols_northBoots$bootstraps,
                     Fols_northBoots$bootstraps
)

# Equal area plot of 95% confidence ellipses from bootstrapping for the Fols (cyan) and Follins (red)
lineEqualAreaPlotTwo(
                     list(FollinFols_northBoots$center),
                     list(Fols_northBoots$center),
                     curves = list(FollinFols_northBoots$points,
                                   Fols_northBoots$points
                     )
)

#————————————————————————————————————————————————————————————

# 2) Three plots to compare the foliations of the Fols (Foliation only data set) and Follins (Foliation-lineation dataset) in the central domain

# Equal area plot of the Fols (cyan) and Follins (red)
lineEqualAreaPlotTwo(
                     Follins$pole[Follins_centerCrit],
                     Fols$pole[Fols_centerCrit]
)

# Equal area plot of the bootstrapped means for the Fols (cyan) and Follins (red)
lineEqualAreaPlotTwo(
                     FollinFols_centerBoots$bootstraps,
                     Fols_centerBoots$bootstraps
)

# Equal area plot of 95% confidence ellipses from bootstrapping for the Fols (cyan) and Follins (red)
lineEqualAreaPlotTwo(
                     list(FollinFols_centerBoots$center),
                     list(Fols_centerBoots$center),
                     curves = list(FollinFols_centerBoots$points,
                                   Fols_centerBoots$points
                     )
)

#————————————————————————————————————————————————————————————

# 3) Three plots to compare the foliations of the Fols (Foliation only data set) and Follins (Foliation-lineation dataset) in the southern domain

# Equal area plot of the Fols (cyan) and Follins (red)
lineEqualAreaPlotTwo(
                     Follins$pole[Follins_southCrit],
                     Fols$pole[Fols_southCrit]
)

# Equal area plot of the bootstrapped means for the Fols (cyan) and Follins (red)
lineEqualAreaPlotTwo(
                     FollinFols_southBoots$bootstraps,
                     Fols_southBoots$bootstraps
)

# Equal area plot of 95% confidence ellipses from bootstrapping for the Fols (cyan) and Follins (red)
lineEqualAreaPlotTwo(
                     list(FollinFols_southBoots$center),
                     list(Fols_southBoots$center),
                     curves = list(FollinFols_southBoots$points,
                                   Fols_southBoots$points
                     )
)

#==================================================================
#==================================================================

#==========================PART II: ORIENTATION STATISTICS ON FOLIATION-LINEATION PAIRS========================================

#These are all foliation-lineation pairs, so they are orientation data. We will proced with methods outlined in Davis and Titus, 2017.

#Since lines on foliation are bidirectional, these are line-in-plane data, and have a four fold symmetry (see Davis and Titus, 2017).

#==========================PLOT THE DATA========================================

# Plot the data in Equal area plot. Lineation (red), Pole to foliation (cyan)
lineEqualAreaPlotTwo(
                     Follins$direction,
                     Follins$pole
)

# Plot the data in an Equal Volume Plot (after Davis and Titus, 2017). Each point represents a foliation-lineation pair. (There are four copies of the data due to mathematical symmetry)
oriEqualVolumePlot(
                   Follins$rotation,
                   oriLineInPlaneGroup
)

# We can also do some basic directional kamb contouring for poles and lines. The numbers are the kamb intervals
lineKambPlot(
             Follins$pole,
             c(2, 4, 6, 8, 10, 12, 14, 18)
)
lineKambPlot(
             Follins$direction,
             c(2, 4, 6, 8, 10, 12, 14, 18)
)

# [!!!]NOTE: This line requires c library to run--skip if you have not compiled c.
# [!!!]Uncomment lines below to Plot 6-sigma kamb contour in an Equal volume plot of Follins.

# oricKambPlot(Follins$rotation,
#              group=oriLineInPlaneGroup,
#              multiple = 6,
#              simplePoints = TRUE,
#              backgroundColor="white", curveColor="black",
#              boundaryAlpha=0,
#              colors="black", axesColors=c("black", "black", "black"),
#              fogStyle="exp")

# If you wish to save this figure, maximize the plot window on your screen before running this line. It will save to your working directory folder.

# afterMaximizingWindow("WestMt_kamb_EqualVol1.png", "WestMt_kamb_EqualVol2.png")

#==========================IDENTIFY GEOGRAPHIC TRENDS========================================

# 1) Visually inspect the possibility of geographic trends in the data

# Plot an Equal Volume plot (after Davis and Titus, 2017), colored by the three domains. Northern (red); Central (green); Southern (blue).
oriEqualVolumePlot(
                   Follins$rotation,
                   group = oriLineInPlaneGroup,
                   backgroundColor = "white",
                   curveColor = "black",
                   boundaryAlpha = 0.2,
                   colors = hues(Follins$domain),
                   axesColors = c("black", "black", "black")
)

# Plot an Equal volume plot of the data, colored by northing
oriEqualVolumePlot(
                   Follins$rotation,
                   group = oriLineInPlaneGroup,
                   backgroundColor = "white",
                   curveColor = "black",
                   boundaryAlpha = 0.2,
                   colors = hues(Follins$northing),
                   axesColors = c("black", "black", "black")
)

# Plot an Equal volume plot of the data, colored by easting
oriEqualVolumePlot(
                   Follins$rotation,
                   group = oriLineInPlaneGroup,
                   backgroundColor = "white",
                   curveColor = "black",
                   boundaryAlpha = 0.2,
                   colors = hues(Follins$easting),
                   axesColors = c("black", "black", "black")
)

# Save EqualVolumePlot figure. If you wish to save this figure, maximize the plot window on your screen before running this line. It will save to your working directory folder.
afterMaximizingWindow(
                      "WestMt_domains_EqualVol.png",
                      "WestMt_domains_EqualVol.png"
)

# Plot Follins in an Equal area plot, colored by domain. Lineation (squares); Foliation (circles)
lineEqualAreaPlot(
                  c(Follins$pole, Follins$direction),
                  col = hues(Follins$domain),
                  shapes = c(replicate(length(Follins$pole), "c"),
                             replicate(length(Follins$direction), "s"))
)

#————————————————————————————————————————————————————————————

# 2) Run regressions to quantify any extant trends.

# 2A) Geodesic regression on all data. Perform a geodesic regression with respect to azimuths every 10 degrees. Each regression asks the question: "does orientation change linearly with respect to an azimuth towards x degrees"
regressionSWestAll <- regressionSweep(Follins, 10, Follins_northCrit | Follins_centerCrit | Follins_southCrit , 0)
westAllRegSum <- data.frame(regressionSWestAll[[19]])
names(westAllRegSum) <- c("Azimuth", "Error", "Min_Eigen", "R_squared", "Pvalue")

# Plot the R^2 value (y-axis) as a function of the azimuth in degrees (x-axis)
plot(
     as.vector(westAllRegSum[, 1]),
     as.vector(westAllRegSum[, 4]),
     main = "Geodesic regressions (all Domains)",
     xlab = "Azimuth in degrees",
     ylab = "R-squared"
)

#————————————————————————————————————————————————————————————

#2B) Perform geodesic regressions on each domain

# Perform a geodesic regression for the northern domain with respect to azimuths every 10 degrees.
regressionSNorth <- regressionSweep(Follins, 10, Follins_northCrit, 0)
NorthRegSum <- data.frame(regressionSNorth[[19]])
names(NorthRegSum) = c("Azimuth", "Error", "Min_Eigen", "R_squared", "Pvalue")

# Check that "Error" = 0, "Min_Eigen" always > 0.
NorthRegSum

# Plot the R^2 value (y-axis) as a function of the azimuth in degrees (x-axis)
plot(
     as.vector(NorthRegSum$Azimuth),
     as.vector(NorthRegSum$R_squared),
     main = "Geodesic regressions (Northern Domain)",
     xlab = "Azimuth in degrees",
     ylab = "R-squared"
)

#————————————————————————————————————————————————————————————

# Perform a geodesic regression for the southern domain with respect to azimuths every 10 degrees.
regressionSCenter <- regressionSweep(Follins, 10, Follins_centerCrit, 0)
CenterRegSum <- data.frame(regressionSCenter[[19]])
names(CenterRegSum) = c("Azimuth", "Error", "Min_Eigen", "R_squared", "Pvalue")

# Check that "Error" = 0, "Min_Eigen" always > 0.
CenterRegSum

# Plot the R^2 value (y-axis) as a function of the azimuth in degrees (x-axis)
plot(
     as.vector(CenterRegSum$Azimuth),
     as.vector(CenterRegSum$R_squared),
     main = "Geodesic regressions (Central Domain)",
     xlab = "Azimuth in degrees",
     ylab = "R-squared"
)

#————————————————————————————————————————————————————————————

# Perform a geodesic regression for the southern domain with respect to azimuths every 10 degrees.
regressionSSouth <- regressionSweep(Follins, 10, Follins_southCrit, 0)
SouthRegSum <- data.frame(regressionSSouth[[19]])
names(SouthRegSum) = c("Azimuth", "Error", "Min_Eigen", "R_squared", "Pvalue")

# Check that "Error" = 0, "Min_Eigen" always > 0.
SouthRegSum

# Plot the R^2 value (y-axis) as a function of the azimuth in degrees (x-axis)
plot(
     as.vector(SouthRegSum$Azimuth),
     as.vector(SouthRegSum$R_squared),
     main = "Geodesic regressions (Southern Domain)",
     xlab = "Azimuth in degrees",
     ylab = "R-squared"
)

#————————————————————————————————————————————————————————————

# 3) Perform a Kernal regression for all Follins.

# Recategorize the symmetric copies of the data.
mu <- oriFrechetMean(Follins$rotation, group=oriLineInPlaneGroup)
Follins$rotation <- oriNearestRepresentatives(Follins$rotation, mu, group=oriLineInPlaneGroup)

# A precomputed value for bandwidth--use this value to save time.

bandwidth <- 0.5879134

# Uncomment line below to compute the appropriate bandwidth for Kernal regression with respect to easting.
bandwidth <- rotBandwidthForKernelRegression(Follins$easting,Follins$rotation, dnorm)

#Run the kernel regression to generate a bunch of points.There were no errors and all minEigenvalues were >0
kernelReg <- lapply(
                    seq(from = min(Follins$easting), to = max(Follins$easting), by = 100),
                    rotKernelRegression,
                    Follins$easting,
                    Follins$rotation,
                    bandwidth,
                    numSteps = 1000
)
sapply(kernelReg, function(regr) regr$error)
sapply(kernelReg, function(regr) {regr$minEigenvalue > 0})

# Plot the regression curve.
kernelRegCurve <- lapply(kernelReg, function(regr) regr$r)
oriEqualVolumePlot(
                   kernelRegCurve,
                   simplePoints = TRUE,
                   oriLineInPlaneGroup
)

# Compute the R^2.
KernRsquared <- rotRsquaredForKernelRegression(Follins$easting, Follins$rotation, bandwidth, numSteps =
                                       1000)
KernRsquared

# Do a permutation test for significance. For the sake of time, we do only 10 permutations, although that is far too few to tell us anything.
rSquareds <- rotKernelRegressionPermutations(Follins$easting, Follins$rotation, bandwidth, numPerms =
                                        1000)
length(rSquareds)
p <- sum(rSquareds > KernRsquared$rSquared)
p

#==========================STATISTICAL DESCRIPTORS========================================

# 1) Northern Domain, n = 16

# Frechet mean (minimizes the Frechet variance).
FrechetMeanNorth <- oriFrechetMean(Follins$rotation[Follins_northCrit], oriLineInPlaneGroup)
FrechetVarNorth <-  oriVariance(Follins$rotation[Follins_northCrit], FrechetMeanNorth, oriLineInPlaneGroup)

# Plot the FrechetMean in an Equal Volume plot
FrechetCurvesNorth <- lapply(Follins$rotation[Follins_northCrit], function(r) rotGeodesicPoints(FrechetMeanNorth, r, 10))
rotEqualAnglePlot(points = Follins$rotation[Follins_northCrit], curves = FrechetCurvesNorth)

# Print the Strike, Dip, Rake of the Frechet mean.
geoStrikeDipRakeDegFromRotation(FrechetMeanNorth)

# Print the Frechet variance.
FrechetVarNorth

#————————————————————————————————————————————————————————————

# 2) Central Domain, n = 34
#Frechet mean minimizes the Frechet variance.
FrechetMeanCenter <- oriFrechetMean(Follins$rotation[Follins_centerCrit], oriLineInPlaneGroup)
FrechetVarCenter <- oriVariance(Follins$rotation[Follins_centerCrit], FrechetMeanCenter, oriLineInPlaneGroup)

#plot the FrechetMean
FrechetCurvesCenter <- lapply(Follins$rotation[Follins_centerCrit], function(r) rotGeodesicPoints(FrechetMeanCenter, r, 10))
rotEqualAnglePlot(
                  points = Follins$rotation[Follins_centerCrit],
                  curves = FrechetCurvesCenter
)

# Print the Strike, Dip, Rake of the Frechet mean.
geoStrikeDipRakeDegFromRotation(FrechetMeanCenter)

# Print the Frechet variance.
FrechetVarCenter

#————————————————————————————————————————————————————————————

# 3) Southern Domain, n = 79
#Frechet mean minimizes the Frechet variance.
FrechetMeanSouth <- oriFrechetMean(Follins$rotation[Follins_southCrit], oriLineInPlaneGroup)
FrechetVarSouth <-  oriVariance(Follins$rotation[Follins_southCrit], FrechetMeanSouth, oriLineInPlaneGroup)

#plot the FrechetMean
FrechetCurvesSouth <- lapply(Follins$rotation[Follins_southCrit], function(r) rotGeodesicPoints(FrechetMeanSouth, r, 10))
rotEqualAnglePlot(points = Follins$rotation[Follins_southCrit], curves = FrechetCurvesSouth)

# Print the Strike, Dip, Rake of the Frechet mean.
geoStrikeDipRakeDegFromRotation(FrechetMeanSouth)

# Print the Frechet variance.
FrechetVarSouth

#————————————————————————————————————————————————————————————

# 4) Dispersion of the data

#The standard way to get at dispersion is to compute the maximum matrix fisher likelihood. The matrix fisher distribution comprises a kind of "mean" and a positive definite symmetric matrix, which characterises the anisotropic dispersion.

# Northern Domain, n = 16. Fisher maximum likelihood
mleNorth <- rotFisherMLE(Follins$rotation[Follins_northCrit])
mleNorth
eigen(mleNorth$kHat, symmetric = TRUE, only.value = TRUE)$values

#Central Domain, n = 34. Fisher maximum likelihood
mleCenter <- rotFisherMLE(Follins$rotation[Follins_centerCrit])
mleCenter
eigen(mleCenter$kHat, symmetric = TRUE, only.value = TRUE)$values

#Southern Domain, n = 79. Fisher maximum likelihood
mleSouth <- rotFisherMLE(Follins$rotation[Follins_southCrit])
mleSouth
eigen(mleSouth$kHat, symmetric = TRUE, only.value = TRUE)$values

#==========================INFERENCE + HYPOTHESIS TESTING========================================

# Here, we can perform some statistical techniques to use information about the samples (each domain) to compute a probability cloud of the mean of the population(s) from which those samples were taken.
# From numerical work in Davis and Titus (2017), MCMC will work the best for small sample sizes that have the matrix fisher anisotropy (eigenvalues) of (large, large, small). All four domains have this anisotropy, and have too few data points to use the (computationally quicker) bootstrapping method.

#We'll do both and compare.

# Compute the bootstrap cloud of means
Follins_northBoots <-  oriBootstrapInference(Follins$rotation[Follins_northCrit], 10000, oriLineInPlaneGroup)
Follins_centerBoots <- oriBootstrapInference(Follins$rotation[Follins_centerCrit], 10000, oriLineInPlaneGroup)
Follins_southBoots <-  oriBootstrapInference(Follins$rotation[Follins_southCrit], 10000, oriLineInPlaneGroup)

# [!!!] Requires C libraries to run.
# [!!!] Compute the Markov chain Monte Carlo cloud of means
# [!!!]Uncomment lines if you have compiled C on your computer and have loaded the C libraries at the top of this script.
#
# northMCMC <-  oricWrappedTrivariateNormalMCMCInference(Follins$rotation[Follins_northCrit],
#                                                       group = oriLineInPlaneGroup,
#                                                       numCollection = 100
#               )
# centerMCMC <- oricWrappedTrivariateNormalMCMCInference(Follins$rotation[Follins_centerCrit],
#                                                        group = oriLineInPlaneGroup,
#                                                        numCollection = 100
#               )
# southMCMC <-  oricWrappedTrivariateNormalMCMCInference(Follins$rotation[Follins_southCrit],
#                                                        group = oriLineInPlaneGroup,
#                                                        numCollection = 100
#               )

#————————————————————————————————————————————————————————————

# 1) Northern v. Central domains

# A) Using MCMC

# [!!!] Uncomment if you ran the MCMC lines above, which required C to be compiled on your system.
# Construct the 95% confidence ellipsoids from small triangles
# trisNorthMCMC <-  rotEllipsoidTriangles(northMCMC$mBar,
#                                         northMCMC$leftCovarInv,
#                                         northMCMC$q095,
#                                         numNonAdapt = 4)
# trisCenterMCMC <- rotEllipsoidTriangles(centerMCMC$mBar,
#                                         centerMCMC$leftCovarInv,
#                                         centerMCMC$q095,
#                                         numNonAdapt = 4)
# Plot the MCMC comparison in an equal Volume plot, with 95% confidence ellipsoids
# oriEqualAnglePlot(
#                   points = c(northMCMC$ms, centerMCMC$ms),
#                   boundaryAlpha = .1,
#                   axesColors = c("black", "black", "black"),
#                   fogStyle = "none",
#                   background = "white",
#                   triangles = c(trisNorthMCMC, trisCenterMCMC),
#                   simplePoints = TRUE,
#                   colors = c(replicate(length(northMCMC$ms), "black"), replicate(length(centerMCMC$ms), "orange")),
#                   group = oriTrivialGroup
# )
# # If you wish to save this figure, maximize the plot window on your screen before running this line. It will save to your working directory folder.
# afterMaximizingWindow("MCMC_WestMt_NC_1.png", "MCMC_WestMt_NC_2.png")
#
# # Plot the MCMC comparison in an Equal Area plot
# lineEqualAreaPlotTwo(c(
#                        lapply(northMCMC$ms, function(s) s[1,]),
#                        lapply(northMCMC$ms, function(s) s[2,])
#                        ),
#                      c(
#                        lapply(centerMCMC$ms, function(s) s[1,]),
#                        lapply(centerMCMC$ms, function(s) s[2,])
# ))

#....................................................................

# B) Using bootstrapping

# Construct the 95% confidence ellipsoids from small triangles
trisNorthBoot <-
    rotEllipsoidTriangles(
        Follins_northBoots$center,
        Follins_northBoots$leftCovarInv,
        Follins_northBoots$q095,
        numNonAdapt = 4
    )
trisCenterBoot <-
    rotEllipsoidTriangles(
        Follins_centerBoots$center,
        Follins_centerBoots$leftCovarInv,
        Follins_centerBoots$q095,
        numNonAdapt = 4
    )

# Plot the bootstrap comparison in an equal Volume plot, with 95% confidence ellipsoids
rotEqualAnglePlot(
    points = c(
        Follins_northBoots$bootstraps,
        Follins_centerBoots$bootstraps
    ),
    triangles = c(trisNorthBoot, trisCenterBoot),
    boundaryAlpha = .1,
    axesColors = c("black", "black", "black"),
    fogStyle = "none",
    background = "white",
    simplePoints = TRUE,
    colors = c(replicate(
        length(Follins_northBoots$bootstraps), "black"
    ), replicate(
        length(Follins_centerBoots$bootstraps), "orange"
    ))
)

# If you wish to save this figure, maximize the plot window on your screen before running this line. It will save to your working directory folder.
afterMaximizingWindow("Boots_WestMt_NC_1.png", "Boots_WestMt_NC_2.png")

# Plot the bootstrap comparison in an Equal Area plot
lineEqualAreaPlotTwo(c(
                       lapply(Follins_northBoots$bootstraps, function(s) s[1,]),
                       lapply(Follins_northBoots$bootstraps, function(s) s[2,])
                       ),
                     c(
                       lapply(Follins_centerBoots$bootstraps, function(s) s[1,]),
                       lapply(Follins_centerBoots$bootstraps, function(s) s[2,])
))

#————————————————————————————————————————————————————————————

# 2) Northern vs. Southern domains

# A) Using MCMC

# [!!!] Uncomment if you ran the MCMC lines above, which required C to be compiled on your system.
# Construct the 95% confidence ellipsoids from small triangles
# trisNorthMCMC <-
#     rotEllipsoidTriangles(northMCMC$mBar,
#                           northMCMC$leftCovarInv,
#                           northMCMC$q095,
#                           numNonAdapt = 5)
# trisSouthMCMC <-
#     rotEllipsoidTriangles(southMCMC$mBar,
#                           southMCMC$leftCovarInv,
#                           southMCMC$q095,
#                           numNonAdapt = 5)
#
# # Plot the bootstrap comparison in an equal Volume plot, with 95% confidence ellipsoids
# oriEqualAnglePlot(
#     points = c(northMCMC$ms, southMCMC$ms),
#     triangles = c(trisNorthMCMC, trisSouthMCMC),
#     boundaryAlpha = 0.1,
#     axesColors = c("black", "black", "black"),
#     fogStyle = "none",
#     background = "white",
#     simplePoints = TRUE,
#     colors = c(replicate(length(northMCMC$ms), "black"), replicate(length(southMCMC$ms), "blue")),
#     group = oriTrivialGroup
# )
#
# # If you wish to save this figure, maximize the plot window on your screen before running this line. It will save to your working directory folder.
# afterMaximizingWindow("MCMC_WestMt_NS_1.png", "MCMC_WestMt_NS_2.png")
#
# # Plot the MCMC comparison in an Equal Area plot
# lineEqualAreaPlotTwo(c(
#     lapply(northMCMC$ms, function(s)
#         s[1,]),
#     lapply(northMCMC$ms, function(s)
#         s[2,])
# ),
# c(
#     lapply(southMCMC$ms, function(s)
#         s[1,]),
#     lapply(southMCMC$ms, function(s)
#         s[2,])
# ))

#....................................................................

# B) Using bootstrapping
# Construct the 95% confidence ellipsoids from small triangles
trisNorthBoot <-
    rotEllipsoidTriangles(
        Follins_northBoots$center,
        Follins_northBoots$leftCovarInv,
        Follins_northBoots$q095,
        numNonAdapt = 4
    )
trisSouthBoot <-
    rotEllipsoidTriangles(
        Follins_southBoots$center,
        Follins_southBoots$leftCovarInv,
        Follins_southBoots$q095,
        numNonAdapt = 4
    )

# Plot the bootstrap comparison in an equal Volume plot, with 95% confidence ellipsoids.
rotEqualAnglePlot(
    points = c(
        Follins_northBoots$bootstraps,
        Follins_southBoots$bootstraps
    ),
    triangles = c(trisNorthBoot, trisSouthBoot),
    boundaryAlpha = .1,
    axesColors = c("black", "black", "black"),
    fogStyle = "none",
    background = "white",
    simplePoints = TRUE,
    colors = c(replicate(
        length(Follins_northBoots$bootstraps), "black"
    ),
    replicate(
        length(Follins_southBoots$bootstraps), "blue"
    ))
)

# If you wish to save this figure, maximize the plot window on your screen before running this line. It will save to your working directory folder.
afterMaximizingWindow("Boots_WestMt_NS_1.png", "Boots_WestMt_NS_2.png")

# Plot the bootstrap comparison in an Equal Area plot
lineEqualAreaPlotTwo(c(
                       lapply(Follins_northBoots$bootstraps, function(s) s[1,]),
                       lapply(Follins_northBoots$bootstraps, function(s) s[2,])
                       ),
                     c(
                       lapply(Follins_southBoots$bootstraps, function(s) s[1,]),
                       lapply(Follins_southBoots$bootstraps, function(s) s[2,])
))

#————————————————————————————————————————————————————————————

# 3) Central vs. Southern domains

# A) Using MCMC
# [!!!] Uncomment if you ran the MCMC lines above, which required C to be compiled on your system.
# # Construct the 95% confidence ellipsoids from small triangles
# trisCenterMCMC <-
#     rotEllipsoidTriangles(centerMCMC$mBar,
#                           centerMCMC$leftCovarInv,
#                           centerMCMC$q095,
#                           numNonAdapt = 4)
# trisSouthMCMC <-
#     rotEllipsoidTriangles(southMCMC$mBar,
#                           southMCMC$leftCovarInv,
#                           southMCMC$q095,
#                           numNonAdapt = 4)
#
# # Plot the bootstrap comparison in an equal Volume plot, with 95% confidence ellipsoids
# oriEqualAnglePlot(
#     points = c(centerMCMC$ms, southMCMC$ms),
#     triangles = c(trisCenterMCMC, trisSouthMCMC),
#     boundaryAlpha = 0.1,
#     axesColors = c("black", "black", "black"),
#     fogStyle = "none",
#     background = "white",
#     simplePoints = TRUE,
#     colors = c(replicate(length(centerMCMC$ms), "orange"), replicate(length(southMCMC$ms), "blue")),
#     group = oriTrivialGroup
# )
#
# # If you wish to save this figure, maximize the plot window on your screen before running this line. It will save to your working directory folder.
# afterMaximizingWindow("MCMC_WestMt_CS_1.png", "MCMC_WestMt_CS_2.png")
#
# # Plot the MCMC comparison in an Equal Area plot
# lineEqualAreaPlotTwo(c(
#     lapply(centerMCMC$ms, function(s)
#         s[1,]),
#     lapply(centerMCMC$ms, function(s)
#         s[2,])
# ),
# c(
#     lapply(southMCMC$ms, function(s)
#         s[1,]),
#     lapply(southMCMC$ms, function(s)
#         s[2,])
# ))

#....................................................................

# B) Using bootstrapping

# Construct the 95% confidence ellipsoids from small triangles
trisCenterBoot <-
    rotEllipsoidTriangles(
        Follins_centerBoots$center,
        Follins_centerBoots$leftCovarInv,
        Follins_centerBoots$q095,
        numNonAdapt = 4
    )
trisSouthBoot <-
    rotEllipsoidTriangles(
        Follins_southBoots$center,
        Follins_southBoots$leftCovarInv,
        Follins_southBoots$q095,
        numNonAdapt = 4
    )

# Plot the bootstrap comparison in an equal Volume plot, with 95% confidence ellipsoids
oriEqualAnglePlot(
    points = c(
        Follins_centerBoots$bootstraps,
        Follins_southBoots$bootstraps
    ),
    triangles = c(trisCenterBoot, trisSouthBoot),
    boundaryAlpha = 0.1,
    axesColors = c("black", "black", "black"),
    fogStyle = "none",
    background = "white",
    simplePoints = TRUE,
    colors = c(replicate(
        length(Follins_northBoots$bootstraps), "orange"
    ), replicate(
        length(Follins_southBoots$bootstraps), "blue"
    )),
    group = oriTrivialGroup
)

# If you wish to save this figure, maximize the plot window on your screen before running this line. It will save to your working directory folder.
afterMaximizingWindow("Boots_WestMt_CS_1.png", "Boots_WestMt_CS_2.png")

# Plot the bootstrap comparison in an Equal Area plot
lineEqualAreaPlotTwo(c(
                       lapply(Follins_centerBoots$bootstraps, function(s) s[1,]),
                       lapply(Follins_centerBoots$bootstraps, function(s) s[2,])
                       ),
                     c(
                       lapply(Follins_southBoots$bootstraps, function(s) s[1,]),
                       lapply(Follins_southBoots$bootstraps, function(s) s[2,])
))


#' Wrapper of constraints to constraint object
#' @param A
#' @param b
#' @param meq
#' @author Kirk Li  \email{kirkli@@stat.washington.edu}
#' @seealso \code{\link{}}
#' @keywords constraint
#' @examples
#' @export
constraints = function(A,b,meq)
{
    list(A=A,b=b,meq=meq)
}

#' GMV Portfolio with Constraints
#' @param cset, if cset = NULL, then unconstrained gmv
#' @param wts.only, for back-test use default wts.only = T, for efficient frontier use wts.only = F
#' @param digits
#' @author Kirk Li  \email{kirkli@@stat.washington.edu}
#' @keywords constraint
#' @examples
#' @export
gmv = function(returns,cset=NULL,wts.only=T,digits = NULL)
{
	require(quadprog)
	require(Rglpk)
	require(corpcor)
   returns.old <- returns

  if (any(c("turnover.hobbs","propcost") %in% cset$clist.names)){
      returns <- cbind(returns,returns,returns)
    }

	makenullmat <- function(A){matrix(0,nrow=nrow(A),ncol=ncol(A))}

  if ("turnover" %in% cset$clist.names){
		returns <- cbind(returns,makenullmat(returns),makenullmat(returns))
	}

    cov.mat <- cov(returns)
    Dmat <- 2*cov.mat
    #Make covariance positive definite
    #This should barely change the covariance matrix, as
    #the last few eigen values are very small negative numbers
    Dmat <- make.positive.definite(Dmat)
    mu <- apply(returns,2,mean)
     #no linear part in this problem
    p = ncol(returns)
    if(is.null(cset))
    {A = matrix(rep(1,p),ncol =1)
    b = 1
    meq = 1}     else
    {A = cset$A
    b = cset$b
    meq = cset$meq}
    dvec <- rep(0,nrow(A))

    port.gmv = solve.QP(Dmat,dvec,A,b,meq)
    wts = port.gmv$solution      # Get optimal weights

    if (any(c("turnover.hobbs","propcost") %in% cset$clist.names)){
      wts = wts[1:(p/3)]+wts[(p/3+1):(p/3*2)]+wts[(p/3*2+1):p]
      mu = sum(wts*mu[1:(p/3)])
      wts = as.matrix(wts)
      sd = as.numeric(sqrt((t(wts)%*%cov(returns.old)%*%wts)))
      wts = as.numeric(wts)
      names(wts)= dimnames(returns.old)[[2]]
    }
	else if("turnover" %in% cset$clist.names){
		wts = wts[1:(p/3)]
		mu = sum(wts*mu[1:(p/3)])
		wts = as.matrix(wts)
		sd = as.numeric(sqrt((t(wts)%*%cov(returns.old)%*%wts)))
		wts = as.numeric(wts)
		names(wts)= dimnames(returns.old)[[2]]
	}
	else{
    mu = sum(wts*mu)
    wts = as.matrix(wts)
    sd = as.numeric(sqrt((t(wts)%*%cov.mat%*%wts)))
    wts = as.numeric(wts)
    names(wts)= dimnames(returns)[[2]] }

   if(!is.null(digits)){
    out = list(WTS = wts,MU.PORT = mu,SD.PORT = sd)
    lapply(out,round,digits)}     else
    {if(wts.only) wts else mu}
}

#' Compute the minimu of mean return using GMV
#' @param returns
#' @param cset
#' @author Kirk Li  \email{kirkli@@stat.washington.edu}
#' @seealso \code{\link{}}
#' @keywords constraint
#' @examples
#' @export
minmu = function(returns, cset = NULL)
{
    gmv(returns,cset,wts.only = F)
}

#' Compute the Max Mean Return Portfolio with Constraints
#' This is primarily to compute the maximum mean return with constraints
#' @param returns
#' @param cset
#' @author Kirk Li  \email{kirkli@@stat.washington.edu}
#' @seealso \code{\link{}}
#' @keywords constraint
#' @examples
#' @export
maxmu = function(returns,cset,mu.only=TRUE,digits = NULL,verbose = FALSE)
{
  returns.old <- returns

#   if (any(c("turnover","propcost") %in% cset$clist.names)){
#     returns <- cbind(returns,returns,returns)
#   }
#
  cov.mat <- cov(returns)
  Dmat <- 2*cov.mat
  #Make covariance positive definite
  #This should barely change the covariance matrix, as
  #the last few eigen values are very small negative numbers
  Dmat <- make.positive.definite(Dmat)
  mu <- apply(returns,2,mean)

  p = ncol(returns)
  if(is.null(cset))
  {A = matrix(rep(1,p),ncol =1)
   b = 1
   meq = 1}     else
   {
    A = cset$A
    b = cset$b
    meq = cset$meq
   }
    d = mu
    A = t(A)  # Because solve.QP uses the transpose of A
    if(meq>0)
    dir = c(rep("==",meq),rep(">=",length(b)-meq)) else
      dir = c(rep(">=",length(b)-meq))
#
#     A <- A[-(1:4),]
#     b <- b[-(1:4)]
#     dir <- dir[-(1:4)]
    port.maxmu = Rglpk_solve_LP(d,A,dir,b,max = TRUE,verbose = verbose)
  # Rglpk doesn't work with turnover/propcost
  if(port.maxmu$status!=0)
    warning("consider possibly relaxing constraints")
    wts = port.maxmu$solution      # Get optimal weights

#
#   if (any(c("turnover","propcost") %in% cset$clist.names)){
#     wts = wts[1:(p/3)]+wts[(p/3+1):(p/3*2)]+wts[(p/3*2+1):p]
#     mu = sum(wts*mu[1:(p/3)])
#     wts = as.matrix(wts)
#     sd = as.numeric(sqrt((t(wts)%*%cov(returns.old)%*%wts)))
#     wts = as.numeric(wts)
#     names(wts)= dimnames(returns.old)[[2]]
#   } else{
    mu = sum(wts*mu)
    wts = as.matrix(wts)
    sd = as.numeric(sqrt((t(wts)%*%cov.mat%*%wts)))
    wts = as.numeric(wts)
    names(wts)= dimnames(returns)[[2]]

# }
  if(!is.null(digits)){
    out = list(WTS = wts,MU.PORT = mu,SD.PORT = sd)
    lapply(out,round,digits)}     else
    {if(mu.only) mu else wts}
}

#' MVO Portfolio with Constraints
#' @param returns
#' @param mu0
#' @param cset
#' @param wts.only
#' @author Kirk Li  \email{kirkli@@stat.washington.edu}
#' @seealso \code{\link{}}
#' @keywords constraint
#' @examples
#' @export
mvo = function(returns,mu0,cset=NULL,wts.only=T,digits = NULL)
{

  if(c("mu.target") %in% cset$clist.names)
    stop("mvo can not handel mu.target constraint")

  returns.old <- returns

  if (any(c("turnover.hobbs","propcost") %in% cset$clist.names)){
    returns <- cbind(returns,returns,returns)
  }

  makenullmat <- function(A){matrix(0,nrow=nrow(A),ncol=ncol(A))}

  if ("turnover" %in% cset$clist.names){
	  returns <- cbind(returns,makenullmat(returns),makenullmat(returns))
  }

  cov.mat <- cov(returns)
  Dmat <- 2*cov.mat
  #Make covariance positive definite
  #This should barely change the covariance matrix, as
  #the last few eigen values are very small negative numbers
  Dmat <- make.positive.definite(Dmat)
  mu <- apply(returns,2,mean)

  p = ncol(returns)
  if(is.null(cset))
  {A = cbind(mu,matrix(rep(1,p),ncol =1))
   b = c(mu0,1)
   meq = 2}     else
   {A = cbind(mu,cset$A)
    b = c(mu0,cset$b)
    meq = cset$meq+1}
  dvec <- rep(0,nrow(A)) #no linear part in this problem
  port.gmv = solve.QP(Dmat,dvec,A,b,meq)
  wts = port.gmv$solution      # Get optimal weights

  if (any(c("turnover.hobbs","propcost") %in% cset$clist.names)){
    wts = wts[1:(p/3)]+wts[(p/3+1):(p/3*2)]+wts[(p/3*2+1):p]
    mu = sum(wts*mu[1:(p/3)])
    wts = as.matrix(wts)
    sd = as.numeric(sqrt((t(wts)%*%cov(returns.old)%*%wts)))
    wts = as.numeric(wts)
    names(wts)= dimnames(returns.old)[[2]]
  }      else if("turnover" %in% cset$clist.names){
	  wts = wts[1:(p/3)]
	  mu = sum(wts*mu[1:(p/3)])
	  wts = as.matrix(wts)
	  sd = as.numeric(sqrt((t(wts)%*%cov(returns.old)%*%wts)))
	  wts = as.numeric(wts)
	  names(wts)= dimnames(returns.old)[[2]]
  }   else{
    mu = sum(wts*mu)
    wts = as.matrix(wts)
    sd = as.numeric(sqrt((t(wts)%*%cov.mat%*%wts)))
    wts = as.numeric(wts)
    names(wts)= dimnames(returns)[[2]] }

  if(!is.null(digits)){
    out = list(WTS = wts,MU.PORT = mu,SD.PORT = sd)
    lapply(out,round,digits)}     else
    {if(wts.only) wts else c(mu,sd,wts)}
}


# VREDNOTENJE EKSOTIČNIH OPCIJ
# Finančni praktikum 2020/21
# Mitja Mandić

library(combinat)
library(Rlab)

#PRVA NALOGA

#Pot opcije, izplačilo prodajne, izplačilo nakupne
prva.opcija <- c(50.00,52.50,49.88,52.37,49.75,52.24) #0, 0
druga.opcija <- c(50.00,52.50,55.12,57.88,60.78,63.81) #7.88,8.69
tretja.opcija <- c(50.00,47.50,49.88,47.38,45.01,42.76) #0,0
cetrta.opcija <- c(50.00,47.50,45.12,47.38,49.75,52.24) #2.26, 2.24
peta.opcija <- c(50.00,52.50,49.88,52.37,54.99,57.74) #2.49, 5.24

izplacilo <- function(vrsta, T, type){
  #če je opcija nakupna, odštevamo maksimume
  if(type == "call"){
    denar <- max((max(vrsta[(T+1):length(vrsta)]) - max(vrsta[1:T])),0)
  }
  #sicer odštevamo minimume
  else if(type == "put"){
    denar <- max((min(vrsta[(T+1):length(vrsta)]) - min(vrsta[1:T])),0)
  }
  return(denar)
}

#DRUGA NALOGA

binomski <- function(S0, u, d, U, R, T, type){
  q = (1 + R - d)/(u - d)

  diskontni.faktor <- 1/(1+R)^U

  #pripravimo si vse možne poti opcije

  poti <- hcube(rep(2,U), translation = -1) * u
  poti[poti < 1] <- d

  #pripravimo si posebno tabelo z verjetnostmi, dejansko nas pa zanima le vrednost zadnjega stolpca
  verjetnosti <- poti
  verjetnosti[verjetnosti == u] <- q
  verjetnosti[verjetnosti == d] <- 1-q

  #verjetnosti zmnožimo
  verjetnosti <- cbind(1,verjetnosti)
  verjetnosti <- t(apply(verjetnosti,1,cumprod))

  #sestavimo skupaj poti opcije in začetno vrednost, vse zmožimo
  cenovni.procesi <- cbind(S0, poti)

  cenovni.procesi <- t(apply(cenovni.procesi,1,cumprod))

  izplacila <- rep(0,length(cenovni.procesi[,1]))

  #izplačamo glede na tip opcije
  for(i in 1:length(cenovni.procesi[,1])){
      izplacila[i] <- izplacilo(cenovni.procesi[i,],T,type)
    }

  pricakovana.izplacila <- izplacila * verjetnosti[,U+1]

  premija  <- sum(pricakovana.izplacila) * diskontni.faktor

  return(premija)
}

#druga b

monte <- function(S0,u,d,U,R,T,type,N){
  #pripravimo si začetne podatke
  q = (1+R-d)/(u-d)

  diskontni.faktor <- 1/(1+R)^U

  izplacila <- rep(0,N)

  #ponavljamo N-krat
  for (i in 1:N){
    #vzorec simuliramo glede na do tveganja nevtralno verjetnost
    vzorec <- sample(c(u,d), (U-1), replace = TRUE, prob = c(q,1-q))

    #sestavimo cenovni proces za ta vzorec poti
    cenovni.proces <- cumprod(append(S0, vzorec))

    #sestavljamo vektor izplačil
    izplacila[i] <- izplacilo(cenovni.proces,T,type) #* verjetnost

  }
  #vse skupaj povprečimo in dobimo rezultat
  povp1 <- 1/N

  pricakovana.izplacila <- sum(izplacila)

  premija <- sum(izplacila) * povp1 * diskontni.faktor

  return(premija)
}

#TRETJA NALOGA

#Vrednostenje opcije po binomskem modelu

po.modelu <- binomski(60,1.05,0.95,15,0.01,8,"put")

#ponavljanje Monte carlo simulacij

desetkrat <- rep(0,100)
stokrat <- rep(0,100)
tisockrat <- rep(0,100)
for (i in 1:100) {
  desetkrat[i] <- monte(60,1.05,0.95,15,0.01,8,"put",10)
  stokrat[i] <- monte(60,1.05,0.95,15,0.01,8,"put",100)
  tisockrat[i] <- monte(60,1.05,0.95,15,0.01,8,"put",1000)
}

#Histogram desetkratne Monte carlo metode
var.desetkrat <- var(desetkrat)
povp.desetkrat <- mean(desetkrat)

hist(desetkrat,freq = 10, xlim = c(0,10), main = paste("Monte Carlo: N = 10"), col = "pink")
abline(v = povp.desetkrat,col = "blue",lwd=2)
abline(v = po.modelu, col = "green", lty = 2)
arrows(x0=povp.desetkrat, y0=0, x1 = povp.desetkrat + var.desetkrat, col="blue", length=0.1, lwd = 2)
arrows(x0=povp.desetkrat, y0=0, x1=povp.desetkrat - var.desetkrat, col="blue", length=0.1, lwd = 2)
legend("topright", legend=c("Monte Carlo", "analiza modela"), col=c("blue","green"), lty=c("solid","dashed"), cex=0.9)

#Histogram 100-kratne
var.stokrat <- var(stokrat)
povp.stokrat <- mean(stokrat)

hist(stokrat,freq = 10, xlim = c(0,10),main = paste("Monte Carlo: N = 100"), col ="pink")
abline(v = povp.stokrat, col = "blue",lwd=2)
abline(v = po.modelu, col = "green",lty = 2)
arrows(x0=povp.stokrat, y0=0, x1 = povp.stokrat + var.stokrat, col="blue", length=0.1, lwd = 2)
arrows(x0=povp.stokrat, y0=0, x1=povp.stokrat - var.stokrat, col="blue", length=0.1, lwd = 2)
legend("topright", legend=c("Monte Carlo", "analiza modela"), col=c("blue","green"), lty=c("solid","dashed"), cex=0.9)

#Histogram 1000 kratne

var.tisockrat <- var(tisockrat)
povp.tisockrat <- mean(tisockrat)

hist(tisockrat,freq = 10, xlim = c(0,10),main = paste("Monte Carlo: N = 1000"), col = "pink")
abline(v = mean(tisockrat), col = "blue",lwd=2)
abline(v = po.modelu, col = "green",lty = 2)
arrows(x0=povp.tisockrat, y0=0, x1 = povp.tisockrat + var.tisockrat, col="blue", length=0.1, lwd = 2)
arrows(x0=povp.tisockrat, y0=0, x1 = povp.tisockrat - var.tisockrat, col="blue", length=0.1, lwd = 2)
legend("topright", legend=c("Monte Carlo", "analiza modela"), col=c("blue","green"), lty=c("solid","dashed"), cex=0.9)


#--------------------------------------------------------------------------
# formant -- Formant response spectrum
#
# Calculate a single-formant impulse response function given the formant
# frequency (f), bandwidth (b), the number of points in the spectrum (np),
# and the maximum frequency.
#
# 12/23/19 -- htb
# Added scale option set to default to FALSE. If true, call frmAmpCorr()
# to obtain a scaling factor based on the frequency and bandwidth that
# can be applied to force unity gain for the resonator at the resonant
# frequency.
#

formant <- function(f, b, np, maxf, scale=FALSE) {
  if (length(f) != length(b) && length(b) > 1)
    return(print("formant: number of bandwidths != number of formants"))

  s <- matrix(seq(0, maxf, maxf/np),nrow=length(f),
              ncol=np+1, byrow=TRUE)
  if (scale)
    scale = 1/frmAmpCorr(f, b)
  else
    scale = 1.0

  bsq <- .25 * b^2
  anum <- (f^2 + bsq)
  return(scale * anum / sqrt(((s-f)^2 + bsq) * ((s+f)^2 + bsq)))
}

formant1d <- function(f, b, np, maxf) {
#
# Calculate a single-formant response function given the
# formant frequency (f), bandwidth (b), the number of points
# in the spectrum (np), and the maximum frequency.
#
  s <- seq(0, maxf, maxf/np)
  bsq <- .25 * b^2
  fsq <- f^2
  fdif <- s - f
  fsum <- s + f
  a <- fdif^2 + bsq
  b <- fsum^2 + bsq
  step1 <- 2.0 * f / sqrt(a*b)
  step2 <- (fsq + bsq) * (a*fsum - b*fdif) / (a*b)^1.5
  return (step1 - step2)
}

band1d <- function(f, b, np, maxf) {
#
# Calculate a single-formant response function given the
# formant frequency (f), bandwidth (b), the number of points
# in the spectrum (np), and the maximum frequency.
#
  s <- seq(0, maxf, maxf/np)
  bsq <- .25 * b^2
  bo2 <- 0.5 * b
  fsq <- f^2
  fdif <- s - f
  fsum <- s + f
  a <- fdif^2 + bsq
  b <- fsum^2 + bsq
  step1 <- bo2 / sqrt(a*b)
  step2 <- (fsq + bsq) * bo2 * (a+b) / (2.0*(a*b)^1.5)
  return (step1 - step2)
}

hpc1 <- function(nf, f, f1) {
#
# This is the higher pole correction originally given by
# Fant (1960) Acoustic Theory of Speech Production
#
  s <- pi^2/8
  for (j in c(1:nf)) {
    s <- s - 1.0/(j*2 - 1)^2
  }
  fr <- f/f1
  return(exp(fr^2 * s))
}

hpc2 <- function(nf, f, f1) {
#
# This is the second order higher pole correction given by
# Gold & Rabiner (1968) Analysis of Digital and Analog Formant
#   Synthesizers. IEEE Transactions on Audio and Electroacoustics,
#   16, 81-94.
#
  s <- pi^2/8
  t <- pi^4/96
  for (j in c(1:nf)) {
    s <- s - 1.0/(j*2 - 1)^2
    t <- t - 1.0/(j*2 - 1)^4
  }
  fr <- f/f1
  return(exp(fr^2 * s + 0.5 * fr^4 * t))
}

hpc3 <- function(nf, f, f1) {
#
# This is the second order higher pole correction given by
# Gold & Rabiner (1968) Analysis of Digital and Analog Formant
#   Synthesizers. IEEE Transactions on Audio and Electroacoustics,
#   16, 81-94.
#
  x <-  c(0.23370055, 0.01467803,0.122589439,0.002332353,0.0825894390,
          0.0007323526,0.0621812758,0.0003158595,0.0498355967,0.0001634437,
          4.157113e-02,9.514233e-05,3.565397e-02,6.012955e-05,3.120953e-02,
          4.037646e-05)
  dim(x) = c(2,8)
  x = t(x)
  s = x[nf,1]
  t = x[nf,2]
  fr <- f/f1
  return(exp(fr^2 * s + 0.5 * fr^4 * t))
}

frmnt <- function(f, ff, fb)
{
  if (ff < 0.0) {
    ff = abs(ff)
    pole = F
  } else {
    pole = T
  }
  bsq <- 0.25 * fb^2
  w <- ff^2 + bsq
  if (pole)
    return (w / sqrt(((f - ff)^2 + bsq) * ((f + ff)^2 + bsq)))
  else
    return (sqrt(((f - ff)^2 + bsq) * ((f + ff)^2 + bsq)) / w)
}

#----------------------------------------------------------------------------
# frmAmpCorr -- Formant Amplitude Correction
#
# The amplitude of a resonator is proportional to both its frequency and
# bandwidth. This function is designed to calculate a scaling factor that
# will compensate both frequency and bandwidth factors to result in unit
# amplitude at the resonator center frequency (i.e. amplitude = 1.0 at
# the resonator characteristic frequency).
#
# The amplitude at the resonant frequency is inversely proportional to the
# bandwidth plus a constant offset that is a nonlinear function of the
# bandwidth. The latter function is approximated here via a 4th order
# polynomial.
#
# See also: function formant() that calculates the discrete spectrum of the
# resonator impulse response given the resonator frequency and bandwidth as
# well as the bandwidth of the spectrum and the number of discrete spectral
# bins. The formant function now also includes a scale argument that
# defaults to FALSE for compatibility with previous versions of the function.
# If scale=TRUE, the amplitude spectrum is scaled to have unit gain at the
# resonator frequency.
#
# 12/23/19 -- htb original code
#  coe <- c(-1.683882e-03,4.234928e-04,-1.231765e-07,2.421068e-11,-2.066097e-15)
#  m <- 1.0 / band
#  b <- coe[1] + coe[2]*band + coe[3]*band^2 + coe[4]*band^3 + coe[5]*band^4
#  cat(paste0("m = ",m,"; b = ",b,"\n"))
#  amp <- m*freq + b
#  return(amp)
#
# 5/5/20  -- htb
#  After looking at the actual formula in formant(), I realized that I was
#  swatting flies with a cannon and replaced the 4th order polynomial fit
#  from the original code, with a simple closed-form exact calculation.
#  YEESH!!
#
#---------------------------------------------------------------------------
#
frmAmpCorr <- function(f, b) {
  bsq <- .25 * b^2
  anum <- (f^2 + bsq)
  return(anum / sqrt(bsq * ((f+f)^2 + bsq)))
}


## create variable y, such that cor(x,y) == r
rcor <- function(x,r) {
    e <- rnorm(length(x), mean=0, sd=sqrt(1-r^2))
    mx <- mean(x)
    sx <- sd(x)
    s <- (x-mx)/sx
    (r*s + e)*sx + mx
}

## create a variable that is correlated with a CpG site s
## and only correlated with surrounding CpG sites to the
## extent that they are correlated with site s.
generate.fake.bump.var <- function(mat, chr, pos, cluster.sites=40, bump.sites=20, cluster.position=0.5, r=0.5, maxgap=500) {
    stopifnot(bump.sites <= cluster.sites)
    stopifnot(cluster.position >= 0 && cluster.position <= 1)
    stopifnot(r >= 0 && r <= 1)
    ## identify clusters
    clusters <- ewaff:::bh.clusterMaker(chr, pos, maxGap=maxgap)
    cluster.size <- table(clusters)

    stopifnot(length(which(cluster.size >= cluster.sites)) > 0)

    cluster.size <- cluster.size[which(cluster.size >= cluster.sites)]

    ## select a cluster
    cluster <- sample(names(cluster.size), 1)

    ## indices of cpg sites in the cluster
    cluster.idx <- which(clusters==cluster)

    ## indices of cpg sites in the bump within in the cluster
    bump.center <- max(1, floor(length(cluster.idx)*cluster.position))
    bump.start <- max(1, bump.center - floor(bump.sites/2))
    bump.end <- min(length(cluster.idx), bump.start + bump.sites -1)
    bump.idx <- cluster.idx[bump.start:bump.end]

    ## standardize methylation levels
    mat.scaled <- t(scale(t(mat[bump.idx,])))

    ## identify the middle CpG site, it will be associated with the variable of interest
    site.idx <- which(bump.idx == cluster.idx[bump.center])

    ## calculate correlation of other CpG sites with the middle CpG site
    r.sites <- apply(mat.scaled, 1, function(mat) cor(mat, mat.scaled[site.idx,]))

    ## generate 100 variables associated with the middle CpG site
    vars <- sapply(1:100, function(i) rcor(mat.scaled[site.idx,], r))
    ## calculate correlation of each variable with each cpg site in the 'bump'
    vars.r <- apply(vars, 2, function(var) apply(mat.scaled, 1, function(mat) cor(mat, var)))
    ## pick the variable that most resembles the relationship of the middle CpG site with the other bump cpG sites
    var.idx <- which.max(apply(vars.r, 2, function(var.r) cor(var.r, r.sites)))
    var <- vars[,var.idx]
    list(var=var, bump.idx=bump.idx, cluster.idx=cluster.idx)
}

## create a variable that corresponds to a true bump
generate.true.bump.var <- function(mat, chr, pos, cluster.sites=40, bump.sites=20, cluster.position=0.5, r=0.5, maxgap=500) {
    stopifnot(bump.sites <= cluster.sites)
    stopifnot(cluster.position >= 0 && cluster.position <= 1)
    stopifnot(r >= 0 && r <= 1)
    ## identify clusters
    clusters <- ewaff:::bh.clusterMaker(chr, pos, maxGap=maxgap)
    cluster.size <- table(clusters)
    cluster.size <- cluster.size[which(cluster.size >= cluster.sites)]

    ## select a cluster
    cluster <- sample(names(cluster.size), 1)

    ## indices of cpg sites in the cluster
    cluster.idx <- which(clusters==cluster)

    ## indices of cpg sites in the bump within in the cluster
    bump.center <- max(1, floor(length(cluster.idx)*cluster.position))
    bump.start <- max(1, bump.center - floor(bump.sites/2))
    bump.end <- min(length(cluster.idx), bump.start + bump.sites -1)
    bump.idx <- cluster.idx[bump.start:bump.end]

    ## sum CpG sites after scaling methylation
    bump.mat <- t(scale(t(mat[bump.idx,,drop=F])))
    bump.avg <- colSums(bump.mat)

    ## create a random variable correlated with the sum
    var <- rcor(bump.avg,r)

    list(var=var, bump.idx=bump.idx, cluster.idx=cluster.idx)
}

generate.spatial <- function(x, distance) {
    mean.cor <- function(distance) 1/exp(distance/200)
    r <- rnorm(1, mean=mean.cor(distance), sd=0.15)
    if (r < -1) r <- -1
    if (r > 1) r <- 1
    rcor(x, r)
}

generate.methylation <- function(n, pos) {
    cpg.mean <- rep(NA, length(pos))
    cpg.mean[1] <- runif(1)
    cpg.change <- rnorm(length(pos), sd=0.1)
    for (i in 2:length(cpg.mean)) {
        new <- cpg.mean[i-1] + cpg.change[i]
        if (new < 0 | new > 1) cpg.change[i] <- -cpg.change[i]
        cpg.mean[i] <- cpg.mean[i-1] + cpg.change[i]
    }

    cpg.sd <- rnorm(length(pos), mean=0.2, sd=0.025)

    methylation <- matrix(NA, ncol=n, nrow=length(pos))
    methylation[1,] <- rnorm(ncol(methylation))
    distance <- tail(pos,-1) - head(pos,-1)
    for (i in 2:nrow(methylation))
        methylation[i,] <- generate.spatial(methylation[i-1,], distance[i-1])

    methylation <- t(scale(t(methylation)))
    methylation <- methylation*cpg.sd + cpg.mean
    idx <- which(methylation < 0 | methylation > 1, arr.ind=T)[,1]
    for (i in unique(idx)) {
        med.cpg <- median(methylation[i,])
        min.cpg <- min(methylation[i,])
        max.cpg <- max(methylation[i,])
        factor.min <- med.cpg/(med.cpg - min.cpg)
        factor.max <- (1-med.cpg)/(max.cpg - med.cpg)
        factor <- 1
        if (min.cpg < 0) factor <- min(factor.min, factor)
        if (max.cpg > 1) factor <- min(factor.max, factor)
        methylation[i,] <- (methylation[i,] - med.cpg)*factor + med.cpg
    }
    methylation
}


#
#

euclidian.distance <- function (a,b)  {
  sqrt (sum((a - b) * (a -b)))
}
log.message <- function (a){
  cat (sprintf ("\n**** %s\n", a))
}

is.multiple <- function  (a ,b) {
  abs(a - round (a / b) * b) < 1e-6
}

error.mat <- function (name, h) {
  tab <- as.matrix (read.table (name))

  dim <- round (0.1 /h )  + 1
  mat = matrix (NA, dim,dim)
  for (p in 1:(length (tab[,1]))) {
    x<-tab[p, 1]
    y<-tab[p,2]
    if (is.multiple (x,h) && is.multiple (y,h))
      {
        x<- round (x/ h ) + 1
        y<- round (y/ h) + 1
        mat[x,y] = tab[p,3]
      }
  }
  mat
}
calc.h <- function (level) {
  0.1/ (2 ^ level)
}

plot.error <- function (mat, h, title) {
  s <- seq (0,0.1,by=h)
  contour (s, s, mat,
           xlab = "x [m]",
           ylab = "y [m]",
           main ='displacement error',
           sub = title)
}

plot3d.error <- function (mat, h, title = "bla")
{
  s <- seq (0,0.1,by=h)
  persp (s, s, mat, scale = TRUE,
         xlab = "x [m]",
         ylab = "y [m]",
         main ='displacement error',
         sub = title,
         zlab = "u error [mm]",
         expand = 0.3,
         phi = 20, theta=30,
#         ltheta = -120,
#         border = "white",
         shade = 0.75, box=TRUE, nticks=5,
         ticktype="detailed"
         )
}

file.mean.max <- function (nm)
{
  mat <-  read.table(nm)
  c(mean(mat[,3]), max(mat[,3]))
}

print.mean.max <- function (nm)
  {
    q <- file.mean.max (nm)
    sprintf ("Avg [mm] : %g, Max [mm]: %g\n", 10^3* q[1], 10^3* q[2])
  }

binary <-  '../needle2d/out-barespeed/needle ' # -odynamic-friction-factor=1.0'

# static.cmd <- paste(binary, ' -Ssynthetic-node-forces -ofix-planes=right -oouter-loop-tolerance=%g ',                    '-oprint-mesh=yes -oinitial-h=%lg -orefinement-h=%g')
static.cmd <- paste(binary, ' -Sangled-forces -ofix-planes=right -oouter-loop-tolerance=%g ',
                    '-oprint-mesh=yes -oinitial-h=%lg -oauto-insert-depth=0.075 -oauto-insert-y=0.0501 -orefinement-h=%g')

my.system <-  function (c) {
  cat (sprintf ("\ninvoking `%s'\n", c))
  st <- system (c)
  if (st) {
    stop (sprintf ("Command failed  (%d)\n", st))
  }
}

plot.error.field <- function (fn, tit, max.level)  {
  mat <- error.mat (fn, calc.h(max.level))
  h <- calc.h (max.level)
  reduced.h  <-  calc.h (min (max.level - 2,
                              7
                              ))
  reduced.mat <-  error.mat (fn, reduced.h)

  cat ("Now processing: ", tit, "\n")

  postscript (file = paste ('needle-', fn, "-3d.eps", sep=""),
              paper="special",
              width = 7.5, height=5,
              horizontal = FALSE)
  plot3d.error (10^3 * reduced.mat, reduced.h, tit)
  dev.off()

  postscript  (file = paste ('needle-', fn, "-cont.eps", sep=""),
               paper="special",
               width = 6, height=4,
               horizontal = FALSE)
  plot.error (10^3 * mat, h, tit)
  dev.off()
}

mat.to.latex.table <- function (m, format="f", digits=2) {
  for (x in 1:length (m[,1])) {
    strvec <- formatC( m[x,], format = format, digits=digits)
    cat (sub ('NA', '   ', strvec),  sep="&");
    cat ("\\\\\n")
  }
}

################################################################
# CG tolerance
################################################################

tolerance.experiment <- function (max.level)  {
  try.tols <- c(0.3, 0.1, 0.03, 0.01, 0.003, 0.001)

  u <- max.level
  r <- max.level
  c <-sprintf (static.cmd, 1e-8, calc.h (u),  calc.h (r))
  my.system (c)
#  my.system ('mv needle-deformation.state static-deformation-reference.state')
  my.system ('mv needle-deformation.state angled-deformation-reference.state')
  for (t in seq (along=try.tols)) {
    c <-sprintf (static.cmd, try.tols[t], calc.h (u),  calc.h (r))
    my.system (c)
    my.system (sprintf ('mv error-plot error-plot-t%d', t))
  }

  avg.max.errs <- matrix (NA, length (try.tols),  3)

  for (t in seq(along=try.tols)) {
    fn <- paste ("error-plot-t",t, sep="")
    tit <- paste ("residual tolerance", try.tols[t])

    plot.error.field(fn,tit,  max.level)

    tab <- read.table (fn)

    avg.max.errs[t,1] <- try.tols[t]
    avg.max.errs[t,2] <- 10^3 * mean (tab[,3])
    avg.max.errs[t,3] <- 10^3 * max (tab[,3])
  }

  cat ("Tolerance dependency, average/maximum error.")
  mat.to.latex.table (avg.max.errs, digits=4)
}

################################################################
# h dependency.
################################################################

calc.static.reference.solution <- function (max.level) {
  cat ("Calculating static reference solution.\n")

  c <-  sprintf (static.cmd, 1e-10, calc.h (max.level),  calc.h (max.level))
  my.system (c)
#  my.system ('mv needle-deformation.state static-deformation-reference.state')
  my.system ('mv needle-deformation.state angled-deformation-reference.state')
}

h.dependency.error.table <- function  (max.level) {
  max.errs = matrix (NA, max.level + 1, max.level + 1)

  for (u in 1:max.level)
    max.errs[1,u+1] = calc.h (u)
  for (r in 1:max.level)
    max.errs[r+1,1] = calc.h (r)
  avg.errs <- max.errs
  iter.counts <- max.errs

  for (u in 1:(max.level -1)) {
    for (r in u:max.level) {
      fn <- sprintf ("error-plot-r%d-u%d",r,u)

      tab <- read.table (fn)
      mat <- tab[,3]

      avg.errs[u+1,r+1] = mean (mat)
      max.errs[u+1,r+1] = max (mat)

      tab <- read.table (sprintf ("iteration-stats-r%d-u%d", r,u))
      iter.counts [u+1,r+1] <- tab[1,1]
    }
  }
  cat ("h_ref/h_initial error estimates\n")

  cat ("Avg errors\n")
  mat.to.latex.table (10^3 * avg.errs)
  cat ("Max errors\n")
  mat.to.latex.table (10^3* max.errs)
  cat ("Iteration counts\n")
  mat.to.latex.table (iter.counts, format = "d")
}

plot.u.r.table <-  function (u,r,max.level)
{
  fn <- paste ("error-plot-r",r, "-u",u, sep="")
  tit <- sprintf ("h-refine = h_%d, h-start = h_%d",r,u)
  plot.error.field(fn,tit,  max.level)
}

static.experiments <-  function (max.level) {
  calc.static.reference.solution (max.level)
  iter.counts = matrix (NA, max.level + 1, max.level + 1)

  tol <- 1e-8
  for (u in 1:(max.level -1)) {
    for (r in u:max.level) {
      c <- sprintf (static.cmd, tol, calc.h (u), calc.h (r))
      my.system (c)
      my.system (sprintf ('mv error-plot error-plot-r%d-u%d', r,u))
      my.system (sprintf ('mv deformed-mesh.eps needle-deformed-mesh-r%d-u%d.eps', r,u))

       my.system (sprintf ('mv iteration-statistics.txt iteration-stats-r%d-u%d', r,u))

    }
  }

  for (u in 1:(max.level -1)) {
    for (r in u:max.level) {
      plot.u.r.table (u,r,max.level)
    }
  }

  h.dependency.error.table (max.level)
}

################################################################
# insertion speed
################################################################

central.insert.y = 0.050001
insertion.tol <- 0.001
insertion.cmd <- sprintf ('%s -oauto-insert-depth=0.08 -Sauto-insert -ofix-planes=right -oauto-insert-y=%g -oouter-loop-tolerance=%g',
                          binary, central.insert.y, insertion.tol)

try.speeds <- c(3.0001, 1.0001, 0.3001, 0.1, 0.03, 0.01)

##
## Computing the  deformation on the fully refined grid is rather expensive. Instead we calc
## force distribution on adaptive grid,  and use that force distr to compute a solution on a full
## grid
##
calc.insert.reference.solution <- function (u, ref) {
  log.message ("Calculating insertion reference solution.\n")
  cmd <-  sprintf ('%s -oauto-insert-speed=%g -orefinement-h=%g',
                   insertion.cmd, 0.005, calc.h (ref))

  my.system (sprintf ('%s -oinitial-h=%g ', cmd, calc.h(u)))

  my.system ('mv graph-needle-forces.txt reference-needle-dump.txt')
  my.system (sprintf ('%s -oinitial-h=%g -Sread-needle-dump ', cmd, calc.h(ref)))

  my.system ('mv needle-deformation.state insert-reference.state')
  my.system (sprintf ('%s -oinitial-h=%g ',
                      cmd, calc.h(u)))
  my.system ('mv error-plot needle-insert-shortcut-error')

  log.message(sprintf ("Shortcut error: %s\n", print.mean.max ('needle-insert-shortcut-error' )))

  plot.error.field ('needle-insert-shortcut-error', "Error caused by shortcutting by refined mesh",
                    ref)

  mat <- 10^3 * read.table ('needle-insert-shortcut-error')

  short.cut.errors <- file.mean.max ('needle-insert-shortcut-error')
  cat (sprintf ("Error caused by short cut: mean %g/max %g\n",  short.cut.errors[1],
                short.cut.errors[2]))

  #
  # we need the 0.0001 epsilon to prevent degeneracies causing endless loops in the needle
  # inserter.
  #
  speed.test.tol <- 0.001

  log.message ("Experimenting with insertion speed.\n")

  speeds <-   try.speeds
  for (i in seq (along =speeds)) {
    s <-  speeds[i]
    c <-  sprintf ("%s -oauto-insert-speed=%e -oinitial-h=%g -orefinement-h=%g",
                   insertion.cmd, s,
                   calc.h (u), calc.h (ref))

    my.system (c)

    my.system (sprintf ('mv error-plot speed-errors-s%d' , i))
    my.system (sprintf ('mv error-plot.xerror speed-errors-s%d.xerror' , i))
  }

  avg.max.errs <- matrix (NA, length (try.speeds), 3)

  for (i in seq (along=try.speeds)) {
    fn <- sprintf ("speed-errors-s%d",i)
    tit <- sprintf ("speed %f h-refine",  try.speeds[i]);

    plot.error.field(fn, tit, ref)
    plot.error.field(paste (fn, ".xerror", sep=""), tit, ref)

    tab <- read.table (fn)

    avg.max.errs[i,1] <- try.speeds [i]
    avg.max.errs[i,2] <- 10^3 * mean (tab[,3])
    avg.max.errs[i,3] <- 10^3 * max (tab[,3])
  }
  cat ("\n\nInsertion speed dependencies\n")
  cat ("avg error [mm]&max error [mm]")
  mat.to.latex.table (avg.max.errs)
}

insertion.experiment <- function(u, r ,  ml)
{
  calc.insert.reference.solution (u, r)
}

################################################################
# Speed  measurements
################################################################

# todo.

cpu.speed.experiment <- function(u, r)
{
  log.message ('Timing experiment')
  insertion.cmd <- sprintf ('%s -oauto-insert-depth=0.08 -Sauto-insert -ofix-planes=bottom -oauto-insert-y=%g -oouter-loop-tolerance=%g',
                            binary, central.insert.y, 0.03)

  speed.tab <- matrix (NA, length (try.speeds), 6)
  for (i in seq (along =try.speeds)) {
    s <-  try.speeds[i]
    cat (s)
    cat (insertion.cmd)
    c <- sprintf ("%s -oauto-insert-speed=%e -oinitial-h=%g -orefinement-h=%g", insertion.cmd, s, calc.h (u), calc.h (r))

    my.system (c)
    stats <- read.table ('speed-stats.txt')

    speed.tab[i,1] <- s
    speed.tab[i,2] <- stats[1, 1]
    speed.tab[i,3] <- stats[1, 2]
    speed.tab[i,4] <- stats[1, 2] / stats[1, 1]
    speed.tab[i,5] <- stats[1, 3] / stats[1, 2]
    speed.tab[i,6] <- stats[1, 4]
  }

  cat ("time [s]&iterations&update freq [Hz]&avg CG iters&max CG iters\n")
  mat.to.latex.table (speed.tab)
}

################################################################
#  Node relocation (first try)
################################################################

relocation.experiment <-  function (max.level) {
  log.message ('relocation error analysis')

  relocate.cmd <- '%s -Sangled-forces -ofix-planes=right -orefinement-h=%g  -oinitial-h=%g -oauto-insert-y=0.05 -oauto-insert-angle=10 -oauto-insert-depth=0.08 -oouter-loop-tolerance=%g '
  tol <-  1e-4
  c <- sprintf(relocate.cmd, binary, calc.h(max.level), calc.h(max.level),
                tol)

  my.system (c)
  my.system ('mv needle-deformation.state angled-deformation-reference.state')
  my.system ('mv iteration-statistics.txt reloc-no-reloc-stats.txt')

  c <- paste (c,  ' -orelocate-nodes=yes')
  my.system (c)
  between.fine <- 10^3 * file.mean.max ("error-plot")

  my.system ('mv iteration-statistics.txt reloc-with-reloc-stats.txt')
  my.system ('mv error-plot relocate-error-between-fine-grid')

  ################
  coarse.ref.level <- max.level -1
  coarse.level <- 3
  coarse.h <- calc.h  (coarse.level)
  coarse.ref.h <- calc.h (coarse.ref.level)

  c <- sprintf(relocate.cmd, binary, coarse.ref.h,coarse.h,
               tol)

  c <- paste (c,  ' -oprint-mesh=yes -orelocate-nodes=yes')
  my.system (c)
  coarse.reloc.errors <- 10^3 * file.mean.max ("error-plot")

  my.system ('mv iteration-statistics.txt reloc-coarse-with-reloc-stats.txt')
  my.system ('mv error-plot relocate-error-coarse-with-relocate')
  my.system ('mv deformed-mesh.eps angled-insert-relocate.eps')

  ################
  c <- paste (c,  ' -orelocate-nodes=no')
  my.system (c)
  coarse.hwn.errors <- 10^3*file.mean.max ("error-plot")
  my.system ('mv error-plot relocate-error-coarse-no-relocate')
  my.system ('mv iteration-statistics.txt reloc-coarse-no-reloc-stats.txt')
  my.system ('mv deformed-mesh.eps angled-insert.eps')
  my.system ('mv needle-deformation.state angled-deformation-reference.state')

  c <- paste (c,  ' -orelocate-nodes=yes')
  my.system (c)
  between.coarse <- 10^3 * file.mean.max ("error-plot")

  #

  ################
  log.message ("Relocation errors");
  cat (sprintf ("With relocation, |fine_{reloc} - fine_{hwn}|  %g&  %g\n",
                between.fine[1], between.fine[2]))
  cat (sprintf ("With relocation, |coarse_{reloc} - fine_{hwn}|  %g&  %g\n",
                coarse.reloc.errors[1], coarse.reloc.errors[2]))
  cat (sprintf ("Without relocation, |coarse_{hwn} - fine_{hwn}|  %g&  %g\n",
                coarse.hwn.errors[1], coarse.hwn.errors[2]))
  cat (sprintf ("Between coarse, |coarse_{hwn} - coarse_{reloc}|  %g&  %g\n",
                between.coarse[1], between.coarse[2]))

  h.descr <- sprintf ("h%d/h%d", as.integer (coarse.ref.level), as.integer (coarse.level))

  plot.error.field  ("relocate-error-coarse-with-relocate",
                     paste ("Error with relocation", h.descr),
                     max.level
                     )

  plot.error.field  ("relocate-error-coarse-no-relocate",
                     paste ("Error without relocation", h.descr),
                     max.level
                     )

  plot.error.field  ("relocate-error-between-fine-grid",
                     sprintf ("Difference between with and without relocation (h%d/h%d)",
                              as.integer (max.level),as.integer (max.level)),
                     max.level
                     )

}

################################################################
# material linearity.
################################################################

nonlinearity.experiment <- function ()  {

  ref.level <- 6
  unif.level <- 3

  nl.cmd <- '%s -Sauto-insert -ofix-planes=right -orefinement-h=%g  -oinitial-h=%g -oauto-insert-y=0.07 -oauto-insert-angle=0 -oauto-insert-speed=0.01 -oauto-insert-depth=0.12 -oouter-loop-tolerance=%g -ofix-planes=bottom -opoisson=0.0'
  tol <-  1e-2
  c <- sprintf(nl.cmd, binary, calc.h (ref.level), calc.h (unif.level),
               tol)

  ## Venant-Kirchoff elasticity has the tendency to hang the simulation, Probably
  ## element inversion is some kind of buckling where K(u) is non-invertible.
  ## Then relaxation does not converge.

  # c.1 <- paste (c, " -oelasticity=nonlinear ")
  #my.system (c.1)
  #my.system ('mv deformed-mesh.eps nonlinear-mesh.eps')
  #Amy.system ('mv reference-mesh.eps nonlinear-ref-mesh.eps')

  c.1 <- paste (c, " -oelasticity=neohooke -orelaxation-type=nonlinear ")
  my.system (c.1)
  my.system ('mv deformed-mesh.eps neohooke-mesh.eps')
  my.system ('mv reference-mesh.eps neohooke-ref-mesh.eps')
  my.system ('mv deformed-boundary.eps neohooke-boundary.eps')
  my.system ('mv reference-boundary.eps neohooke-ref-boundary.eps')

  c.1 <- paste (c, " -oelasticity=consistent-veronda -orelaxation-type=nonlinear ")
  my.system (c.1)
  my.system ('mv deformed-mesh.eps consistent-vw-mesh.eps')
  my.system ('mv reference-mesh.eps consistent-vw-ref-mesh.eps')
  my.system ('mv deformed-boundary.eps consistent-vw-boundary.eps')
  my.system ('mv reference-boundary.eps consistent-vw-ref-boundary.eps')

  c.2 <- paste (c, " -oelasticity=linear ")
  my.system (c.2)
  my.system ('mv deformed-mesh.eps linear-mesh.eps')
  my.system ('mv reference-mesh.eps linear-ref-mesh.eps')
  my.system ('mv deformed-boundary.eps linear-boundary.eps')
  my.system ('mv reference-boundary.eps linear-ref-boundary.eps')

  c.2 <- paste (c, " -oelasticity=neohooke -orefinement-h=0.003125 -oinitial-h=0.025 ")
  my.system (c.2)
  my.system ('mv deformed-mesh.eps needle-nh-coarse-mesh.eps')
  my.system ('mv reference-mesh.eps needle-nh-coarse-ref-mesh.eps')
  my.system ('mv deformed-boundary.eps needle-nh-coarse-boundary.eps')
  my.system ('mv reference-boundary.eps needle-nh-coarse-ref-boundary.eps')
}

################################################################
# misc examples
################################################################

force.distribution.graph <-  function() {
  my.system (paste (binary , '-Sgraph-friction '))

  fr <-  read.table ("force-graph.txt")
  fr[,1] = max(fr[,1]) - fr[,1]

  postscript (file = 'needle-friction-graph.eps',
              paper = "special",
              width = 6, height=4,
              horizontal = FALSE)
  plot (fr[,1], fr[,2], ylab = 'Friction force [N/m]',
        xlab = 'Coordinate along needle [m]',
        type = 'l')
  dev.off()
}

bisection.example <-  function( )
  {
    append.point <- function(nm) {
      f <- file (nm, "a")
      cat ("\n0.0702 0.0351  0.0015 0 360 arc closepath  fill \n ", file = f)
      close (f)
    }

    my.system (paste(binary, " -Sshow-refinement"))
    for (i in 0:9) {
      append.point (sprintf ("maubach-refinement-%d.eps", i))
    }
    append.point (sprintf ("maubach-no-refinement.eps", i))
  }

################################################################
# all experiments
################################################################

everything <- function (ml) {
  my.system ('make conf=barespeed')

  out.dir <- 'experiments'
  oldwd <- getwd()
  setwd (out.dir)

  ################
  # put the newest at the top, since that is changed most often.
  nonlinearity.experiment ()
  static.experiments (ml)

  cpu.speed.experiment (3,7)
  cpu.speed.experiment (3,6)

  relocation.experiment (ml)

  insertion.experiment(3,6,6)

  tolerance.experiment (ml)

  ####

  bisection.example()
  force.distribution.graph ()

  setwd (oldwd)
}


################################################################################
# Monte Carlo Simulation and Resampling Methods in Social Science              #
# Thomas M. Carsey and Jeffrey J. Harden                                       #
# Chapter 6 File (Parallel Processing 2 of 2)                                  #
# Last update: 1/31/13                                                         #
################################################################################

# Negative Binomial vs. Zero-Inflated Negative Binomial (parallel processing)
library(pscl)
library(snow)
library(doSNOW)
library(foreach)

cl.tmp <- makeCluster(4)
registerDoSNOW(cl.tmp)

# Zero-inflated negative binomial random number generator
rzinbinom <- function(n, mu, size, zprob){
ifelse(runif(n) < zprob, 0, rnbinom(n, size = size, mu = mu))
}

# Simulation function
zinb.sim <- function(n = 1000){
require(pscl)
par.est.zinb <- matrix(NA, nrow = 1, ncol = 4) # Empty matrix to store the
                                               # estimates
b0 <- .2 # True value for the intercept
b1 <- .5 # True value for the slope
X <- runif(n, -1, 1) # Create a sample of n observations on the
                     # independent variable X

# Generate data with a zero-inflation component
Y.zi <- rzinbinom(n, mu = exp(b0 + b1*X), size = .5,
zprob = exp(b0 + b1*X)/(1 + exp(b0 + b1*X)))
# Generate data with no zero-inflation component
Y.nozi <- rzinbinom(n, mu = exp(b0 + b1*X), size = .5, zprob = 0)
model.nb1 <- glm.nb(Y.zi ~ X) # Standard negative binomial
model.nb2 <- glm.nb(Y.nozi ~ X)
model.zinb1 <- zeroinfl(Y.zi ~ X | X, dist = "negbin") # Zero-inflated model
model.zinb2 <- zeroinfl(Y.nozi ~ X | X, dist = "negbin")
# Store the estimates of the coefficient on X (count equation)
par.est.zinb[ , 1] <- model.nb1$coef[2] # Standard NB, with ZI
par.est.zinb[ , 2] <- model.nb2$coef[2] # Standard NB, no ZI
par.est.zinb[ , 3] <- as.numeric(model.zinb1$coef$count[2]) # ZI NB, with ZI
par.est.zinb[ , 4] <- as.numeric(model.zinb2$coef$count[2]) # ZI NB, no ZI
return(par.est.zinb)
}

# Parallel Processing
set.seed(2837) # Set the seed for reproducible results
reps <- 1000 # Set the number of repetitions

start.time <- Sys.time()
results <- foreach(i = 1:reps, .combine = rbind) %dopar% {
zinb.sim(n = 1000)
}

end.time <- Sys.time()
end.time - start.time


# Propiedades numéricas del OLS, Gauss-Markov, sesgo de variable omitida
#################################################################
cat("\014")
rm(list=ls())
graphics.off()

#################################################################
# Motivacion
#################################################################

# Ademas de trabajar con incertidumbre (intervalos de confianza, p-values, etc.),
# la estadistica inferencial (lo que estamos haciendo este semestre)
# descansa sobre supuestos muy importantes.

# Es importante conocer estos supuestos. Te daras cuenta que
# la principal herramienta cuantitativa de las ciencias sociales
# tiene muchos defectos y/o supuestos irreales. En consecuencia, siempre
# actua con prudencia y humildad respecto a tus resultados.

#################################################################
# Supuestos de los modelos lineales
#################################################################

# (1) El error tiene promedio cero: por eso SIEMPRE calcula los errores y plotealos.
# (2) El error tiene varianza constante: idem.
# (3) El error no esta correlacionado (los errores son independientes entre si): idem.
# (4) El error esta normalmente distribiuido: idem.
# (5) Las X's estan medidas sin error, y son independientes del error.
# (6) Las X's no son invariables, es decir, las X's son variables, no constantes.

# (*) Punto sobre la diferencia entre ERROR y RESIDUO:
## recuerda que y = b0 + b1x1 + e.
## Ese "e" en realidad, es un residuo, no "error". "Parametro de poblacion."

#################################################################
# Teorema de Gauss-Markov
#################################################################

# el fundamento matematico de OLS (modelos lineales), es el
# Teorema de Gauss-Markov.

# Consiste en lo siguiente: si
## (a) el error tiene promedio cero, y
## (b) si el error esta normalmente distribuido, y
## (c) si el error tiene varianza constante,
# entonces nuestros betas son los estimadores mas eficientes y sin sesgo.

# En ingles, es conocido como "BLUE": "best linear unbiased estimator".

# En otras palabras, cuando todos los supuestos funcionan,
# la diferencia entre la MATRIZ QUE CONTIENE TODOS LOS BETAS CORRECTOS,
# Y LA MATRIZ QUE NOSOTROS TENEMOS ACCESO (O POODEMOS OCUPAR) ES CERO.

# (1) Punto del modelo "real" ("true model").
# (2) Punto del epsilon (error) y la letra "e" (residuo).
# (3) Punto del beta y la letra "b".

# Son diferencias filosoficas. Importantes...pero filosoficas.

# Que puede salir mal?
## Ej.: los errores no son independientes; es decir, son dependientes.
### Caso de las series de tiempo.

#################################################################
# Sesgo de Variable Omitida: "omitted variable bias"
#################################################################

# Todos los supuestos de OLS operan bajo otro supuesto: el modelo que
# estimamos, es el "verdadero modelo". Es decir, no se nos queda ninguna
# variable afuera: i.e., todas las variables que debieramos ocupar, estan
# consideradas. Si esto falla, todo falla, y tenemos "el sesgo de la variable
# omitida".

# Mal que mal, OLS es una ecuacion, y el valor de los betas cambiara si es que
# no incluimos todas las variables que debieramos incluir.

## ILUSTRAR EN LA PIZARRA.

# Para demostrar este punto, simularemos (inventaremos) unos datos.

# Inventemos las variables independientes
set.seed(2020)
x1 = rnorm(1000, mean=0, sd=1) # como nunca, conocemos que el promedio REAL de esta variable es 0
x2 = rnorm(1000, mean=2, sd=2) # como nunca, conocemos que el promedio REAL de esta variable es 2
x3 = rnorm(1000, mean=1, sd=3) # como nunca, conocemos que el promedio REAL de esta variable es 1
x4 = x1*x2

# Definamos que, como debiera ser, el error tiene promedio cero.
e = rnorm(1000, 0)

# Establecer el valor real de los betas: conocemos con exactitud los valores,
# porque nosotros los creamos!
b1 = 1
b2 = -1
b3 = 5
b4 = -2

# El "VERDADERO MODELO": "y" es una combinacion lineal de todas las variables.
y = b1*x1 + b2*x2 + b3*x3 + b4*x4 + e # true model

hist(y)

# Hagamos una regresion.
modelo.completo = lm(y ~ x1 + x2 + x3 + x4)
summary(modelo.completo) # sin sorpresa, los betas son los mismos que inventamos nosotros.

# (1) La tabla de "Residuals" dice que la mediana es 0. Eso es genial. Pero sin sorpresas, nosotros inventamos todo, asi que obvio que resulta bien.
# (2) Plotiemos los errores

plot(modelo.completo$fitted.values, modelo.completo$residuals)

# Perfecto! No notamos ningun patron.
# Es decir, vemos una nube desordenada de puntos.
# Aqui es cuando VEMOS lo que asumimos: los errores se cancelan entre si.

# Variable Omitida: Que pasa con nuestros coeficientes cuando se nos quedan dos
# variables afuera?

modelo.segado = lm(y ~ x1)

summary(modelo.segado) # Ya los resultados son muy diferentes.

# (1) Mediana de los residuos?
# (2) Plotiemos los errores?

plot(modelo.segado$fitted.values, modelo.segado$residuals)

# Promediemos el error
options(scipen = 1000000) # apagar notacion cientifica.
mean(modelo.segado$residuals)

# Que vemos aqui?
# Que implica?

#################################################################
# Atencion
#################################################################

# Lo peor de todo, es que nunca sabras si te faltan variables o no.
# Es por esto que lo que guia el proceso de anadir/remover variables, es
# teoria. Es un proceso casi artistico.