#对三种液体的不同ov，bv进行比较，放在一起
#文件名：voltage_3liquids ,
#ov and bv电压，6条曲线，在不同的x轴上显示，比如，随着流量，极间距离和针头直径的变化
#三张图，1，1,2,3

######################读取文件模块###################
setwd("D:/data")
library(xlsx)

#读取数据
de_q<-read.xlsx("voltage.xls",sheetName="ethanol_q",header=TRUE)
da_q<-read.xlsx("voltage.xls",sheetName="acetone_q",header=TRUE)
di_q<-read.xlsx("voltage.xls",sheetName="iso_q",header=TRUE)

de_h<-read.xlsx("voltage.xls",sheetName="ethanol_h", header=TRUE)
da_h<-read.xlsx("voltage.xls",sheetName="acetone_h", header=TRUE)
di_h<-read.xlsx("voltage.xls",sheetName="iso_h", header=TRUE)

de_r<-read.xlsx("voltage.xls",sheetName="ethanol_r", header=TRUE)
da_r<-read.xlsx("voltage.xls",sheetName="acetone_r", header=TRUE)
di_r<-read.xlsx("voltage.xls",sheetName="iso_r", header=TRUE)

#规划figure界面
par(mfrow=c(2,2), mar=c(6,4,2,2), oma=c(2,2,2,2))
#layout(matrix(c(1,2,3,4), 2, 2, byrow = TRUE))

#保存pdf
#pdf("voltage_3liquids.pdf")

###############################随流量变化，6条曲线#############################
#乙醇
#OV

plot(de_q$flowrate, de_q$OV,  col=0, xaxs="i", xlim=c(-0.002, 0.032), ylim=c(1, 3),
xlab="Flow rate (nl/min)", cex.lab=1.1, ylab="Voltage (HV)", main="Voltage changes with Q")

model_qov <- loess(de_q$OV ~ de_q$flowrate)
fit <- fitted(model_qov)
ord <- order(de_q$flowrate)

lines(de_q$flowrate[ord], fit[ord], type="b", col="red", lwd=2.5, lty=2)

#BV
#points(de_q$flowrate, de_q$BV,  pch=6, col=0, xaxs="i", xlim=c(-0.002, 0.032), ylim=c(2, 3),
#xlab="Flow rate (nl/min)", cex.lab=1.1, ylab="Break Voltage (HV)", main="Break Voltage changes with Flowrate")

model_qbv <- loess(de_q$BV ~ de_q$flowrate)
fit <- fitted(model_qbv)
ord <- order(de_q$flowrate)

lines(de_q$flowrate[ord], fit[ord], type="b", col="red", lwd=2.5, lty=2)

#丙酮
#OV
model_aov <- loess(da_q$OV ~ da_q$flowrate)
fit <- fitted(model_aov)
ord <- order(da_q$flowrate)

lines(da_q$flowrate[ord], fit[ord], type="b", col="blue", pch=23, lwd=2.5, lty=2)

#BV
model_abv <- loess(da_q$BV ~ da_q$flowrate)
fit <- fitted(model_abv)
ord <- order(da_q$flowrate)

lines(da_q$flowrate[ord], fit[ord], type="b", col="blue", pch=23, lwd=2.5, lty=2)

#异丙醇
#OV
model_iov <- loess(di_q$OV ~ di_q$flowrate)
fit <- fitted(model_iov)
ord <- order(di_q$flowrate)

lines(di_q$flowrate[ord], fit[ord], type="b", col="darkgreen", pch=24, lwd=2.5, lty=2)

#BV
model_ibv <- loess(di_q$BV ~ di_q$flowrate)
fit <- fitted(model_ibv)
ord <- order(di_q$flowrate)

lines(di_q$flowrate[ord], fit[ord], type="b", col="darkgreen", pch=24, lwd=2.5, lty=2)

box("figure", lty="dotted", col="blue")

#图例
#legend("center", c("Ethanol OV", "Ethanol BV"，"Acetone OV"，"Acetone BV", "Isoproply OV"， "Isoproply BV"),  pch=c(6, 6, 23，23, 24, 24), col=c("red", "red", "blue","blue", "darkgreen", "darkgreen"), lty=2, lwd=2, cex=1)

##############################图裂#################################
#图例

plot(de_q$flowrate, de_q$BV,  yaxt="n", xaxt= "n", col=0,  xlab="", ylab="", xlim=c(-0.002, 0.032), ylim=c(1, 3), main="Legend")
text(0.002, 2.8, "Up Red - Ethanol", line=6, col="red", adj=0, cex=1.2)
text(0.002, 2.5, "Down Red - Ethanol", line=5, col="red", adj=0, cex=1.2)
text(0.002, 2.2, "Up Blue - Acetone", line=4, col="blue", adj=0, cex=1.2)
text(0.002, 1.9, "Down blue - Acetone", line=3, col="blue", adj=0, cex=1.2)
text(0.002, 1.6, "Up Green - Isoproply", line=2, col="darkgreen", adj=0, cex=1.2)
text(0.002, 1.3, "Down Green - Isoproply", line=1, col="darkgreen", adj=0, cex=1.2)
#legend(0.012,2.5, c("Ethanol OV", "Ethanol BV"，"Acetone OV"，"Acetone BV", "Isoproply OV"， "Isoproply BV"),  pch=c(6, 6, 23，23, 24, 24), col=c("red", "red", "blue","blue", "darkgreen", "darkgreen"), lty=2, lwd=2, cex=1)

box("figure", lty="dotted", col="blue")

###############################随极间距离变化，6条曲线#############################
#乙醇
#OV
plot(de_h$distance, de_h$OV,  col=0, xaxs="i", xlim=c(0, 4.2), ylim=c(1, 3.2),
xlab="Distance (mm)", cex.lab=1.1, ylab="Voltage (HV)", main="Voltages changes with H")

model_hov <- loess(de_h$OV ~ de_h$distance)
fit <- fitted(model_hov)
ord <- order(de_h$distance)

lines(de_h$distance[ord], fit[ord], type="b", col="red", lwd=2.5, lty=2)

#BV
model_hBV <- loess(de_h$BV ~ de_h$distance)
fit <- fitted(model_hBV)
ord <- order(de_h$distance)

lines(de_h$distance[ord], fit[ord], type="b", col="red", lwd=2.5, lty=2)

#丙酮
#OV
model_aov <- loess(da_h$OV ~ da_h$distance)
fit <- fitted(model_aov)
ord <- order(da_h$distance)

lines(da_h$distance[ord], fit[ord], type="b", col="blue", pch=23, lwd=2.5, lty=2)

#BV
model_aBV <- loess(da_h$BV ~ da_h$distance)
fit <- fitted(model_aBV)
ord <- order(da_h$distance)

lines(da_h$distance[ord], fit[ord], type="b", col="blue", pch=23, lwd=2.5, lty=2)

#异丙醇
#OV
model_iov <- loess(di_h$OV ~ di_h$distance)
fit <- fitted(model_iov)
ord <- order(di_h$distance)

lines(di_h$distance[ord], fit[ord], type="b", col="darkgreen", pch=24, lwd=2.5, lty=2)

#BV
model_iBV <- loess(di_h$BV ~ di_h$distance)
fit <- fitted(model_iBV)
ord <- order(di_h$distance)

lines(di_h$distance[ord], fit[ord], type="b", col="darkgreen", pch=24, lwd=2.5, lty=2)

box("figure", lty="dotted", col="blue")

#图例
#legend("center", c("Ethanol OV", "Ethanol BV"， "Acetone OV"，"Acetone BV", "Isoproply OV"， "Isoproply BV"),  pch=c(6, 6,23，23, 24, 24), col=c("red", "red", "blue","blue", "darkgreen", "darkgreen"), lty=2, lwd=2.5, cex=1)

###############################随针头直径变化，6条曲线#############################
#乙醇
#OV
plot(de_r$radius, de_r$OV,  col=0, xaxs="i", xlim=c(0.2, 0.9), ylim=c(1, 3.2),
xlab="Outer Diameter (mm)", cex.lab=1.1, ylab="Voltage (HV)", main="Voltages changes with D")

model_eov <- loess(de_r$OV ~ de_r$radius)
fit <- fitted(model_eov)
ord <- order(de_r$radius)

lines(de_r$radius[ord], fit[ord], type="b", col="red", lwd=2.5, lty=2)
#BV
model_ebv <- loess(de_r$BV ~ de_r$radius)
fit <- fitted(model_ebv)
ord <- order(de_r$radius)

lines(de_r$radius[ord], fit[ord], type="b", col="red", lwd=2.5, lty=2)

#丙酮
#OV
model_aov <- loess(da_r$OV ~ da_r$radius)
fit <- fitted(model_aov)
ord <- order(da_r$radius)

lines(da_r$radius[ord], fit[ord], type="b", col="blue", pch=23, lwd=2.5, lty=2)
#BV
model_abv <- loess(da_r$BV ~ da_r$radius)
fit <- fitted(model_abv)
ord <- order(da_r$radius)

lines(da_r$radius[ord], fit[ord], type="b", col="blue", pch=23, lwd=2.5, lty=2)

#异丙醇
#OV
model_iov <- loess(di_r$OV ~ di_r$radius)
fit <- fitted(model_iov)
ord <- order(di_r$radius)

lines(di_r$radius[ord], fit[ord], type="b", col="darkgreen", pch=24, lwd=2.5, lty=2)
#BV
model_ibv <- loess(di_r$BV ~ di_r$radius)
fit <- fitted(model_ibv)
ord <- order(di_r$radius)

lines(di_r$radius[ord], fit[ord], type="b", col="darkgreen", pch=24, lwd=2.5, lty=2)

box("figure", lty="dotted", col="blue")


#' Occupancy index
#'
#' @description Prints the estimates of the occupancy index,
#' as described in Diana et al. (2021).
#'
#' @param modelResults Output of the function \code{runModel}
#'
#' @importFrom magrittr %>%
#'
#' @export
#'
#' @return A data.frame with of the 95\% credible interval and the median.
#'
#' @examples
#'
#' printOccupancyIndex(sampleResults)
#'
printOccupancyIndex <- function(modelResults){

  years <- modelResults$dataCharacteristics$Years
  Y <- length(years)

  psi_mean_output <- modelResults$modelOutput$psi_mean_output
  psi_mean_output <- apply(psi_mean_output, 3, c)

  CI_psi_mean <- apply(psi_mean_output, 2, function(x){
    c(stats::quantile(x, probs = c(0.025, .5, 0.975)))
  })

  colnames(CI_psi_mean) <- years

  CI_psi_mean <- as.data.frame(CI_psi_mean)

  CI_psi_mean
}

#' Estimates of covariates on occupancy probability
#'
#' @description Prints the estimates of the covariates on the occupancy probability.
#'
#' @param modelResults Output of the function \code{runModel}
#'
#' @importFrom magrittr %>%
#'
#' @export
#'
#' @return A data.frame with of the 95\% credible interval and the median.
#'
#' @examples
#'
#' printOccupancyCovariatesEffect(sampleResults)
#'
printOccupancyCovariatesEffect <- function(modelResults) {
  usingSpatial <- modelResults$dataCharacteristics$usingSpatial

  X_tilde <- modelResults$dataCharacteristics$X_tilde
  if (usingSpatial) {
    X_centers <- nrow(X_tilde)
  } else {
    X_centers <- 0
  }

  years <- modelResults$dataCharacteristics$Years
  Y <- length(years)

  numTimeSpaceCov <-
    modelResults$dataCharacteristics$numTimeSpaceCov

  namesCovariates <-
    modelResults$dataCharacteristics$nameVariables_psi
  ncov_psi <- length(namesCovariates)

  if (usingSpatial) {
    namesCovariates_xt <- c("X_T", "Y_T")
  } else {
    namesCovariates_xt <- c()
  }

  namesCovariates_all <- c(namesCovariates_xt, namesCovariates)
  ncov_psi_all <- ncov_psi + numTimeSpaceCov

  beta_psi_output <- modelResults$modelOutput$beta_psi_output

  beta_psi_output <- apply(beta_psi_output, 3, c)

  betaeffect <-
    apply(beta_psi_output[, Y + X_centers + 1:ncov_psi_all], 2, function(x) {
      stats::quantile(x, probs = c(0.025, 0.5, 0.975))
    })

  colnames(betaeffect) <- namesCovariates_all

  betaeffect <- as.data.frame(betaeffect)

  betaeffect
}

#' Estimates of detection probability
#'
#' @description Prints the estimates of the detection probability.
#'
#' @param modelResults Output of the function \code{runModel}
#'
#' @importFrom magrittr %>%
#'
#' @export
#'
#' @return A data.frame with the 95\% credible interval and the median.
#'
#' @examples
#'
#' printBaseLineCaptureProb(sampleResults)
#'
printBaseLineCaptureProb <- function(modelResults) {

  usingYearDetProb <- modelResults$dataCharacteristics$usingYearDetProb
  years <- modelResults$dataCharacteristics$Years
  Y <- length(years)

  p_intercepts <- ifelse(usingYearDetProb, Y, 1)

  beta_p_output <- modelResults$modelOutput$beta_p_output

  beta_p_output <- apply(beta_p_output, 3, c)

  peffect <-
    apply(beta_p_output[, 1:p_intercepts,drop = F], 2, function(x) {
      stats::quantile(logit(x), probs = c(0.025, 0.5, 0.975))
    })

  if(usingYearDetProb){
    colnames(peffect) <- years
  } else {
    colnames(peffect) <- ""
  }

  peffect <- as.data.frame(peffect)

  peffect
}

#' Estimates of covariates on detection probability
#'
#' @description Prints the estimates of the covariates on the detection probability.
#'
#' @param modelResults Output of the function \code{runModel}
#'
#' @importFrom magrittr %>%
#'
#' @export
#'
#' @return A data.frame with the 95\% credible interval and the median.
#'
#' @examples
#'
#' printDetectionCovariatesEffect(sampleResults)
#'
printDetectionCovariatesEffect <- function(modelResults){

  usingYearDetProb <- modelResults$dataCharacteristics$usingYearDetProb
  years <- modelResults$dataCharacteristics$Years
  Y <- length(years)

  p_intercepts <- ifelse(usingYearDetProb, Y, 1)

  namesCovariates <- modelResults$dataCharacteristics$nameVariables_p
  ncov_p <- length(namesCovariates)

  if (ncov_p > 0) {
    beta_p_output <- modelResults$modelOutput$beta_p_output

    beta_p_output <- apply(beta_p_output, 3, c)

    betaeffect <- apply(beta_p_output[, -(1:p_intercepts), drop = F], 2, function(x) {
      stats::quantile(x, probs = c(0.025, 0.5, 0.975))
    })

    betaeffect <- as.data.frame(betaeffect)

    return(betaeffect)
  } else {
    print("No detection covariates")

    return(NULL)
  }

}


## ----echo=FALSE---------------------------------------------------------
knitr::opts_chunk$set(
  echo=FALSE,
  message = FALSE,
  warning = FALSE,
  error = FALSE,
  collapse = TRUE,
  comment = "",
  out.width = "80%",
  fig.height = 6,
  fig.width = 10,
  fig.align = "center",
  fig.retina = 3,
  cache = FALSE
)

## ----load libraries, echo=FALSE-----------------------------------------
library(tidyverse)
library(ggmap)
library(here)

## ----not to run this code, eval=FALSE-----------------------------------
## # Data extracted from ALA with this code
## # Note that package ALA4Ris being replaced by package galah
## # install.packages("galah")
## library(galah)
## ala_config(atlas = "Australia", download_reason_id=)
## l <- ala_species("Platypus")
##
## taxa <- select_taxa("Ornithorhynchus anatinus", counts = TRUE)
##
## platypus <- ala_occurrences(taxa = taxa)
##
## platypus <- platypus %>% rename(
##   longitude = decimalLongitude,
##   latitude = decimalLatitude
## )
## save(platypus, file="data/platypus.rda")

## ----load the platypus obervation data, echo=TRUE-----------------------
load(here::here("data/platypus.rda"))
platydata <- platypus
ggplot(data=platydata) + geom_point(aes(x=longitude, y=latitude))

## ----Add some transparency to see density of locations, echo=TRUE-------
ggplot(data=platydata) + geom_point(aes(x=longitude, y=latitude), alpha=0.1)

## ----making a map projection, echo=TRUE, fig.height=10, out.width="100%"----
ggplot(data=platydata) +
  geom_point(aes(x=longitude, y=latitude), alpha=0.1) +
  coord_map()

## ----you need a developer API to run this code, echo=FALSE, eval=FALSE----
## library(ggmap)
## register_google(XXX)
## oz <- get_map(location=c(lon=133.8807, lat=-23.6980), zoom=4)
## save(oz, file="data/oz.rda")

## ----load the saved map data, echo=TRUE---------------------------------
load(here::here("data/oz.rda"))
ggmap(oz) +
  geom_point(data=platydata, aes(x=longitude, y=latitude),
              alpha=0.1, colour="orange")

## ----leaflet map, echo=TRUE---------------------------------------------
library(leaflet)
platydata %>%
  filter(!is.na(latitude), !is.na(longitude), !(eventDate=="")) %>%
  leaflet() %>%
  addTiles() %>%
  addCircleMarkers(
    radius=1, opacity = 0.5, color = "orange", label = ~eventDate,
    lat = ~latitude, lng = ~longitude)

## ----create a date variable, echo=TRUE----------------------------------
library(lubridate)
platydata <- platydata %>%
  mutate(eventDate = ymd_hms(eventDate))

## ----show sightings over time, echo=TRUE, out.width="60%"---------------
ggplot(data=platydata) +
  geom_point(aes(x=eventDate, y=1))

## ----show jittered sightings over time, echo=TRUE, out.width="60%"------
ggplot(data=platydata) +
  geom_jitter(aes(x=eventDate, y=1))

## ----focus on records since 1900 and count the number for each year, echo=TRUE, out.width="60%"----
platydata1900 <- platydata %>% filter(year>1900) %>%
  count(year)
ggplot(data=platydata1900) +
  geom_point(aes(x=year, y=n))

## ----solution code for filtering on location and time, eval=FALSE-------
## # Check odd cases
## platydata %>% filter(latitude < (-50))
## # These just have the lat/long wrong
## platydata %>% filter(eventDate < ymd("1850-01-01"))

## ----add a trend line, echo=TRUE, out.width="60%"-----------------------
ggplot(data=platydata1900, aes(x=year, y=n)) +
  geom_point() +
  geom_smooth(se=F)

## ----make it interactive to investigate some observations, echo=TRUE----
library(plotly)
ggplotly()

## ----solution code to density plot on map, eval=FALSE, echo=FALSE-------
## ggmap(oz) +
##   geom_density2d(data=platydata, aes(x=longitude, y=latitude),
##               colour="orange")

## ----eval=FALSE, echo=FALSE---------------------------------------------
## Not a lot different. It shows perhaps high density regions around Melbourne, Brisbane and south of Sydney. These match high population sites, though, and maybe reiterates the sampling being convenience sampling. We miss the smaller areas of sightings, like northern Queensland.

## ----solution code for exploring population trend, echo=FALSE, eval=FALSE----
## platydata_50_10 <- platydata %>% filter(year>1949, year<2020) %>%
##   mutate(decade = cut(year, breaks=seq(1950, 2020, 10),
##    include.lowest=TRUE,
##    labels=c("50-59", "60-69", "70-79", "80-89", "90-99", "00-09", "10-19")))
## ggmap(oz) + geom_point(data=platydata_50_10, mapping=aes(x=longitude, y=latitude), colour="orange", alpha=0.1) +
##   facet_wrap(~decade)


# Code used to create charts for 1.2 Grammar of Graphics
# Not for distribution to students

library(tidyverse)
baseball <- read_csv("/Users/mchapple/Desktop/baseball.csv")

baseball <- baseball %>%
  gather(year, wins, -Team) %>%
  rename(team=Team)

baseball$year <- as.integer(baseball$year)
baseball$team <- as.factor(baseball$team)

ggplot(data=baseball, mapping=aes(x=year, y=wins)) +
  geom_point()

ggplot(data=baseball, mapping=aes(x=year, y=wins)) +
  geom_point(mapping=aes(shape=team))

ggplot(data=baseball, mapping=aes(x=year, y=wins)) +
  geom_point(mapping=aes(color=team))

ggplot(data=baseball, mapping=aes(x=year, y=wins)) +
  geom_line(mapping=aes(color=team))

baseball %>%
  filter(team=='New York Mets' | team=='New York Yankees') %>%
  ggplot(mapping=aes(x=year, y=wins)) +
  geom_line(mapping=aes(color=team))

baseball %>%
  filter(team=='New York Mets' | team=='New York Yankees') %>%
  ggplot(mapping=aes(x=year, y=wins)) +
  geom_col(mapping=aes(fill=team), position="dodge") +
  coord_cartesian(ylim=c(60,105))


require(reshape2) # For data handling
require(lme4) # Linear mixed-effects models
require(DHARMa) # Evaluate model fit
require(car) # Anova() function [instead of base R anova()]
require(emmeans) # Post-hoc analysis on the model

rm(list = ls()) # Remove variables/objects
graphics.off() # Close any open graphics

ELP_09 = read.csv("./Data/ELP_09_octopamine_side_learning_Y_maze.csv", header = TRUE, stringsAsFactors = FALSE, sep = ";")
head(ELP_09, n = 1) # Check if data was imported correctly

ELP_09$Solution = ifelse(ELP_09$Solution == "B", "0.01mM Octopamine", "Control")

ELP_09$Initial_Decision_Binary = ifelse(ELP_09$Initial_Decision == ELP_09$Reward_Side, 1, 0)
ELP_09$Final_Decision_Binary = ifelse(ELP_09$Final_Decision == ELP_09$Reward_Side, 1, 0)
ELP_09$Switched_Decision_Binary = ifelse(ELP_09$Initial_Decision_Binary == ELP_09$Final_Decision_Binary, 0, 1)
paste0("Ants switched their final decision in ", round(sum(ELP_09$Switched_Decision_Binary) / nrow(ELP_09) * 100, 0), "% of the visits!")

table(ELP_09$Solution, ELP_09$Reward_Side) / 4

for (i in 1:nrow(ELP_09)) {
  if (ELP_09$Visit[i] == "2" & !is.na(ELP_09$Bridge_Nest_Duration[i])) {
    if (ELP_09$Bridge_Nest_Duration[i] != ELP_09$Time_Since_Marking[i]) {
      print(paste0("Warning: Row ", i, " was changed from ", ELP_09$Bridge_Nest_Duration[i], "s to ", ELP_09$Time_Since_Marking[i], "s!"))
      ELP_09$Bridge_Nest_Duration[i] = ELP_09$Time_Since_Marking[i]
    }
  }
  else if (ELP_09$Visit[i] == "2" & is.na(ELP_09$Bridge_Nest_Duration[i])) {
    ELP_09$Bridge_Nest_Duration[i] = ELP_09$Time_Since_Marking[i]
    print(paste0("Warning: Row ", i, " was changed and Bridge_Nest_Duration was NA!"))
  }
}

for (i in 1:nrow(ELP_09)) {
  if (ELP_09$Time_Since_Marking[i] <= 1800) {
    ELP_09$TSM_Bin[i] = "0-30"
  }
  else if (ELP_09$Time_Since_Marking[i] > 1800 & ELP_09$Time_Since_Marking[i] <= 3600) {
    ELP_09$TSM_Bin[i] = "30-60"
  }
  else {
    print("Warning: Undefined bins!")
  }
}

table(ELP_09$Solution, ELP_09$TSM_Bin, ELP_09$Reward_Side) / 4

ELP_09$Collection_Date = as.factor(ELP_09$Collection_Date)
ELP_09$Time_Collection = as.factor(ELP_09$Time_Collection)
ELP_09$Experimentor = as.factor(ELP_09$Experimentor)
ELP_09$Starvation_Period = as.factor(ELP_09$Starvation_Period)
ELP_09$Donor_Colony = as.factor(ELP_09$Donor_Colony)
ELP_09$Recipient_Colony = as.factor(ELP_09$Recipient_Colony)

ELP_09$Visit = as.factor(ELP_09$Visit)
ELP_09$Solution = as.factor(ELP_09$Solution)
ELP_09$Solution = relevel(ELP_09$Solution, "Control")
ELP_09$Reward_Side = as.factor(ELP_09$Reward_Side)
ELP_09$TSM_Bin = as.factor(ELP_09$TSM_Bin)

ELP_09$Initial_Decision_Binary = as.factor(ELP_09$Initial_Decision_Binary)
ELP_09$Final_Decision_Binary = as.factor(ELP_09$Final_Decision_Binary)

initial_final_diff = melt(ELP_09, measure.vars = c("Initial_Decision_Binary", "Final_Decision_Binary"))
initial_final_diff$value = as.factor(initial_final_diff$value)
head(initial_final_diff, n = 1) # Check if data was imported correctly

diff_model = glmer(value ~ variable + (1|Starvation_Period) + (1|Experimentor/Collection_Date), data = initial_final_diff,family = binomial, glmerControl(optimizer = "bobyqa", optCtrl = list(maxfun = 1000000000)))
Anova(diff_model)

e = emmeans(diff_model, ~variable, type = "response")
pairs(e)

mod1 = glmer(Final_Decision_Binary ~ (Reward_Side + Solution + TSM_Bin + Visit)^2  +
               (1|Starvation_Period) + (1|Collection_Date),
             data = ELP_09, family = "binomial", glmerControl(optimizer = "bobyqa", optCtrl = list(maxfun = 1000000000)))

simres = simulateResiduals(mod1)
plot(simres, asFactor = T)

summary(mod1)
Anova(mod1)
drop.scope(mod1)

mod2 = update(mod1, . ~ . - Reward_Side:TSM_Bin)
anova(mod1, mod2)

summary(mod2)
Anova(mod2)
drop.scope(mod2)

mod3 = update(mod2, . ~ . - Reward_Side:Solution)
anova(mod2, mod3)

summary(mod3)
Anova(mod3)
drop.scope(mod3)

mod4 = update(mod3, . ~ . - Solution:Visit)
anova(mod3, mod4)

summary(mod4)
Anova(mod4)
drop.scope(mod4)

mod5 = update(mod4, . ~ . - Reward_Side:Visit)
anova(mod4, mod5)

summary(mod5)
Anova(mod5)
drop.scope(mod5)

mod6 = update(mod5, . ~ . - TSM_Bin:Visit)
anova(mod5, mod6)

summary(mod6)
Anova(mod6)
drop.scope(mod6)

mod7 = update(mod6, . ~ . - Solution:TSM_Bin)
anova(mod6, mod7)

summary(mod7)
Anova(mod7)
drop.scope(mod7)

anova(mod1, mod7)
simres = simulateResiduals(mod6)
plot(simres, asFactor = T)

meanobj = emmeans(mod7, ~Reward_Side, type = "response")
pairs(meanobj, adjust = "bonferroni")

meanobj = emmeans(mod7, ~TSM_Bin * Visit, type = "response")
test(meanobj)

meanobj = emmeans(mod7, ~Solution, type = "response")
test(meanobj)
pairs(meanobj, adjust = "bonferroni")

meanobj = emmeans(mod7, ~1, type = "response")
test(meanobj)

sessionInfo()


###################################################################
#
# This script looks at the number of cells that have expression
# of a given molecule below a given threshold.
#
###################################################################

singleCellBelowThres <- function(geneList,theThres=1){

	# Load signel cell data.
	source('~/Dropbox (HHMI)/research/reviews/shah2016/loadSingleCellAllHipp.r')

	loadSingleCellHipp()

	toKeep <- geneList[geneList%in%rownames(scHipp)]
	tempCount <- scHipp[toKeep,]
print(head(tempCount))
	tempThres <- apply(tempCount,1,max)<theThres

	print(paste('Of',nrow(tempCount),'cells,',
		sum(tempThres),'have a count less than',theThres))
}


'
Создать функцию, которая по переданному параметру возвращает
наименование дня недели на русском языке.
Если переданное число больше 7, делить на 7 и определять день недели по остатку от деления.
Если число меньше 1, функция возвращает пробел.
Если число действительное, округлять до целого.
'
#Функция
calc <- function(number, parameter = "rus") {
  #Округление
  number <- round(number, 0)

  #Если больше - берем остаток
  if (number > 7) {
    number <- number %% 7
  }
  #Если меньше 1 - пробел
  if (number < 1) {
    return(" ")
  }

  #Если есть английский - выводим на англе
  if (is.element(parameter,
                 c("Eng", "eng", "English", "english", "англ", "Англ", "анг"))) {
    day <- switch (
      number,
      "Monday",
      "Tuesday",
      "Wednesday",
      "Thursday",
      "Friday",
      "Saturday",
      "Sunday"
    )
    #Если нет английского -выводим на русском
  } else{
    day <- switch (
      number,
      "Понедельник",
      "Вторник",
      "Среда",
      "Четверг",
      "Пятница",
      "Суббота",
      "Воскресенье"
    )
  }

  #Отдаем значение
  return(day)
}

#Основная программа
{
  #Запускаем функцию нормально
  result <- calc(20)
  print(result)

  result <- calc(20, "Eng")
  print(result)
}


library(tidyverse)
library(lubridate) # used to order by date
library(ggplot2)

# Read the datasets
cases <- read_csv("https://raw.githubusercontent.com/CSSEGISandData/COVID-19/master/csse_covid_19_data/csse_covid_19_time_series/time_series_covid19_confirmed_global.csv")
death <- read_csv("https://raw.githubusercontent.com/CSSEGISandData/COVID-19/master/csse_covid_19_data/csse_covid_19_time_series/time_series_covid19_deaths_global.csv")
uscases <- read_csv("https://raw.githubusercontent.com/CSSEGISandData/COVID-19/master/csse_covid_19_data/csse_covid_19_time_series/time_series_covid19_confirmed_US.csv")
usdeath <- read_csv("https://raw.githubusercontent.com/CSSEGISandData/COVID-19/master/csse_covid_19_data/csse_covid_19_time_series/time_series_covid19_deaths_US.csv")
bed <- read_csv("/Users/naoki_atkins/Desktop/data.csv")
demo <- read_csv("/Users/naoki_atkins/Desktop/demographics.csv")
usdemo <- read_csv("/Users/naoki_atkins/Desktop/usdemo/4781d818-9392-462a-b22b-0c425d61815c_Data.csv")

##################
# Data Wrangling #
##################

# Pull out just one country from the dataset so that we can perform validation
#cases %>%
#  filter(`Country/Region` == "Japan") %>%

# Tidying the data
cases.tidy <- cases %>%
  pivot_longer(cols = 5:ncol(cases), names_to = "Date", values_to = "confirmed")

# Tidying the data
death.tidy <- death %>%
  pivot_longer(cols = 5:ncol(death), names_to = "Date", values_to = "deaths")

# Tidying the data
uscases.tidy <- uscases %>%
  pivot_longer(cols = 12:ncol(uscases), names_to = "Date", values_to = "confirmed")

# Tidying the data
usdeath.tidy <- usdeath %>%
  pivot_longer(cols = 13:ncol(usdeath), names_to = "Date", values_to = "deaths")

# Tidying the data
demo.tidy <- demo %>%
  group_by(`Country Code`) %>%
  select(-`Series Name`) %>%
  pivot_wider(names_from = `Series Code`, values_from = `YR2015`) %>%
  ungroup()

usdemo.tidy <- usdemo %>%
  select(-`Series Name`,
         -`Country Code`,
         -`2010 [YR2010]`,
         -`2011 [YR2011]`,
         -`2012 [YR2012]`,
         -`2013 [YR2013]`,
         -`2014 [YR2014]`,
         -`2015 [YR2015]`,
         -`2016 [YR2016]`,
         -`2017 [YR2017]`,
         -`2018 [YR2018]`) %>%
  drop_na() %>%
  pivot_wider(names_from = `Series Code`, values_from = `2019 [YR2019]`)

usdemo.tidy <- usdemo.tidy %>%
  mutate(SP.POP.80UP.TOTL = SP.POP.80UP.FE + SP.POP.80UP.MA)

usdemo.tidy <- usdemo.tidy %>%
  rename(SP.POP.0014.TOTL = SP.POP.0014.TO) %>%
  rename(SP.POP.1564.TOTL = SP.POP.1564.TO) %>%
  rename(SP.POP.65UP.TOTL = SP.POP.65UP.TO) %>%
  select(-SP.POP.80UP.FE, -SP.POP.80UP.MA)

# Extract the most recent year for every country - all other years are not necessary to keep
bed.tidy <- bed %>%
  group_by(Country) %>%
  filter(Year == max(Year)) %>%
  ungroup()

# Add male and female populations together - not examining sex-related differences
demo.tidy <- demo.tidy %>%
  mutate(SP.POP.80UP.TOTL = SP.POP.80UP.FE + SP.POP.80UP.MA) %>%
  mutate(SP.POP.1564.TOTL = SP.POP.1564.FE.IN + SP.POP.1564.MA.IN) %>%
  mutate(SP.POP.0014.TOTL = SP.POP.0014.FE.IN + SP.POP.0014.MA.IN) %>%
  mutate(SP.DYN.AMRT.TOTL = SP.DYN.AMRT.FE + SP.DYN.AMRT.MA) %>%
  mutate(SP.POP.65UP.TOTL = SP.POP.65UP.FE.IN + SP.POP.65UP.MA.IN)

# Rename header
bed.tidy <- bed.tidy %>%
  rename(HospitalBeds = `Hospital beds (per 10 000 population)`)

# Rename header
cases.tidy <- cases.tidy %>%
  rename(ProvinceState = `Province/State`) %>%
  rename(Country = `Country/Region`)

# Rename header
death.tidy <- death.tidy %>%
  rename(ProvinceState = `Province/State`) %>%
  rename(Country = `Country/Region`)

# Rename header
demo.tidy <- demo.tidy %>%
  rename(Country = `Country Name`) %>%
  rename(CountryCode = `Country Code`)

# Rename countries in a standard format so we can join tables later
bed.tidy <- bed.tidy %>%
  mutate(Country = replace(Country, Country == "Republic of Korea", "South Korea")) %>%
  mutate(Country = replace(Country, Country == "Democratic People's Republic of Korea", "North Korea")) %>%
  mutate(Country = replace(Country, Country == "Iran (Islamic Republic of)", "Iran")) %>%
  mutate(Country = replace(Country, Country == "United Kingdom of Great Britain and Northern Ireland", "United Kingdom")) %>%
  mutate(Country = replace(Country, Country == "United States of America", "US"))

# Renaming countries
cases.tidy <- cases.tidy %>%
  mutate(Country = replace(Country, Country == "Korea, South", "South Korea"))

# Renaming countries
death.tidy <- death.tidy %>%
  mutate(Country = replace(Country, Country == "Korea, South", "South Korea"))

# Renaming countries
demo.tidy <- demo.tidy %>%
  mutate(Country = replace(Country, Country == "Korea, Rep.", "South Korea")) %>%
  mutate(Country = replace(Country, Country == "Korea, Dem. People’s Rep.", "North Korea")) %>%
  mutate(Country = replace(Country, Country == "Iran, Islamic Rep.", "Iran"))

# Rename header
usdemo.tidy <- usdemo.tidy %>%
  rename(Country = `Country Name`)

usdemo.tidy <- usdemo.tidy %>%
  mutate(Country = replace(Country, Country == "United States", "US"))

# Summing up all the provinces/state into country
cases.tidy <- cases.tidy %>%
  group_by(Country, Date) %>%
  summarise(confirmed = sum(confirmed)) %>%
  arrange(mdy(Date)) %>%
  ungroup()

uscases.tidy <- uscases.tidy %>%
  group_by(Country_Region, Date) %>%
  summarise(confirmed = sum(confirmed)) %>%
  arrange(mdy(Date)) %>%
  ungroup

# Summing up all the provinces/state into country
death.tidy <- death.tidy %>%
  group_by(Country, Date) %>%
  summarise(deaths = sum(deaths)) %>%
  arrange(mdy(Date)) %>%
  ungroup()

usdeath.tidy <- usdeath.tidy %>%
  group_by(Country_Region, Date) %>%
  summarise(deaths = sum(deaths)) %>%
  arrange(mdy(Date)) %>%
  ungroup

# Rename header
uscases.tidy <- uscases.tidy %>%
  rename(Country = Country_Region)

# Rename header
usdeath.tidy <- usdeath.tidy %>%
  rename(Country = Country_Region)

covid <- cases.tidy %>%
  full_join(uscases.tidy) %>%
  full_join(death.tidy) %>%
  full_join(usdeath.tidy) %>%
  full_join(bed.tidy) %>%
  full_join(demo.tidy) %>%
  full_join(usdemo.tidy)

covid <- covid %>%
  select(-SP.POP.80UP.FE,
         -SP.POP.80UP.MA,
         -SP.DYN.AMRT.FE,
         -SP.DYN.AMRT.MA,
         -SP.DYN.LE00.IN,
         -SP.POP.1564.MA.IN,
         -SP.POP.1564.FE.IN,
         -SP.POP.0014.MA.IN,
         -SP.POP.0014.FE.IN,
         -SP.POP.TOTL.FE.IN,
         -SP.POP.TOTL.MA.IN,
         -SP.POP.65UP.FE.IN,
         -SP.POP.65UP.MA.IN,
         -SP.DYN.AMRT.TOTL,
         -SP.URB.TOTL,
         -CountryCode,
         -Year)

###########################
# Standardizing Variables #
###########################

# Helper function to help us make proportions
convert_population_to_decimal <- function(value, total) {
  return(value/total)
}

# Transforming population counts to proportion of total population
covid <- covid %>%
  mutate(across(SP.POP.80UP.TOTL:SP.POP.65UP.TOTL, ~convert_population_to_decimal(value = .x, total = SP.POP.TOTL))) %>%
  drop_na()

##############

covid$Date <- as.Date(covid$Date, format = "%m/%d/%y")

countries <- covid$Country %>% unique()

##############

# Plotting the Residuals
##############
library(modelr)

covidCopy <- covid %>%
  add_residuals(model)

ggplot(aes(Date, resid), data = covidCopy) +
  geom_point()

# Visualize the model
##############

### Model Multiplication
model2 <- covid %>%
  lm(formula = deaths ~ confirmed * HospitalBeds * SP.POP.TOTL * SP.POP.80UP.TOTL * SP.POP.1564.TOTL * SP.POP.65UP.TOTL * SP.POP.0014.TOTL)

pred <- covid %>%
  add_predictions(model = model2)

# R2 of .9941
summary(model2)

### Model Addition
model3 <- covid %>%
  lm(formula = deaths ~ confirmed + HospitalBeds + SP.POP.TOTL + SP.POP.80UP.TOTL + SP.POP.1564.TOTL + SP.POP.65UP.TOTL + SP.POP.0014.TOTL)

pred <- covid %>%
  add_predictions(model = model3)

# R2 of .8071
summary(model3)

### Model Mix of Multiplication and Addition
model4 <- covid %>%
  lm(formula = deaths ~ Date * confirmed * HospitalBeds * SP.POP.TOTL * SP.POP.80UP.TOTL * SP.POP.1564.TOTL + SP.POP.65UP.TOTL + SP.POP.0014.TOTL)

pred <- covid %>%
  add_predictions(model = model4)

# R2 of .8071
summary(model4)

#setwd("/Users/naoki_atkins/Desktop/plots")
 setwd("/Users/naoki_atkins/Desktop/plotsForAddition")

### NOTE FOR MYSELF
### The reason I think this is not working is because I split the data into a training set and testing set
### Instead, I want to train everything, the entire dataset
for (elem in countries){
  country <- toString(elem, width = 30)

  print(  pred %>%
    filter(Country == country) %>%
    ggplot() +
    geom_point(mapping = aes(x=Date, y=deaths)) +
    geom_line(mapping = aes(x=Date, y = pred), color = "blue") +
    labs(title = country))

  countryName <- gsub(" ", "_", toString(elem, width = 30))

# print(paste(countryName, sep = "", ".png"))

  dev.copy(png, paste(countryName, sep = "", ".png"))
  dev.off()
}

##############

library(caret)

set.seed(1996)
inTrain <- createDataPartition(y = covid$deaths, p = .8, list = FALSE)
str(inTrain)

training <- covid[ inTrain,]
testing  <- covid[-inTrain,]

nrow(training)
nrow(testing)

model <- training %>%
  lm(formula = deaths ~ Date * confirmed * HospitalBeds * SP.POP.TOTL * SP.POP.80UP.TOTL * SP.POP.1564.TOTL * SP.POP.65UP.TOTL * SP.POP.0014.TOTL)

prediction <- predict(model, testing, interval = "prediction", level = 0.95)

table(training$deaths, prediction)
##############

# WORKED!
covid %>%
  keep(is.numeric) %>%                     # Keep only numeric columns
  gather() %>%                             # Convert to key-value pairs
  ggplot(aes(value)) +                     # Plot the values
  facet_wrap(~ key, scales = "free") +   # In separate panels
  geom_density()

# doesn't work
covid %>%
  lm(formula = deaths ~ SP.POP.80UP.TOTL) %>%
  summary() %>%
  coef() %>%
  fortify() %>%
  ggplot()

# R2 value of .8045
reg <- covid %>%
  lm(formula = deaths ~ confirmed + HospitalBeds + SP.POP.80UP.TOTL + SP.POP.65UP.TOTL + SP.POP.1564.TOTL + SP.POP.0014.TOTL)

summary(reg)

# R2 value of .8031
## Most of the variability in deaths is explained by the 1. # of confirmed cases
##                                                       2. proportion of population over the age of 80
##                                                       3. # of hospital beds
ageAsACauseOfDeath <- covid %>%
  lm(formula = deaths ~ confirmed + SP.POP.80UP.TOTL + HospitalBeds)

summary(ageAsACauseOfDeath)


#!/usr/bin/env Rscript

# A reference class for a report
#
# Author: Cody Lewis
# Date: 2019-05-01

Report <- R6::R6Class(
    "Report",
    list(
        service = 0,
        capability = 0,
        time = 0,
        note = 0,
        issuer = 0,
        issuer.QR = 0,
        issuer.time.QR = 0,
        server = FALSE,
        disregard = FALSE,

        initialize = function(service, capability, time, note, issuer,
                              issuer.QR, issuer.time.QR, disregard=FALSE) {
            self$service <- service
            self$capability <- capability
            self$time <- time
            self$note <- note
            self$issuer <- issuer
            self$issuer.QR <- issuer.QR
            self$issuer.time.QR <- issuer.time.QR
            self$server <- FALSE
            self$disregard <- disregard
        }
    )
)

# Find the one dimensional distance between the target and current
find.diff <- function(target, current) {
    return(abs(target - current))
}

# Find the distance of a report from the target
report.distance <- function(report, target.service, target.capability,
                            service.max, capability.max, eta) {
    service.max = service.max + 1
    capability.max = capability.max + 1
    dS.max.squared = find.diff(target.service, service.max)**2
    dC.max.squared = find.diff(target.capability, capability.max)**2
    term.shared = sqrt(
        (dS.max.squared + dC.max.squared) *
            (
                (
                    find.diff(target.service, report$service)**2 /
                        dS.max.squared
                ) +
                (
                    find.diff(target.capability, report$capability)**2 /
                        dC.max.squared
                )
            )
    )
    if(report$note >= 0) {
        term.unique = sqrt(
            (dS.max.squared + dC.max.squared) *
                (
                    (
                        (service.max - report$service) /
                            (service.max - (target.service - eta))
                    )**2 +
                    (
                        report$capability / (target.capability + eta)
                    )**2
                )
        )
    } else {
        term.unique = sqrt(
            (dS.max.squared + dC.max.squared) *
                (
                    (
                        (capability.max - report$capability) /
                            (capability.max - (target.capability - eta))
                    )**2 +
                    (report$service / (target.service + eta))**2
                )
        )
    }
    return(min(term.shared, term.shared))
}

# Return a weight for a report, stating its relevance
report.weigh <- function(report, dist, lambda, theta, time.current) {
    s = (1 / 2) * (report$note**2 - report$note)
    return(lambda**dist * theta**((s + 1) * (time.current - report$time)))
}

# Find the threshold value that states whether a report should be rejected if
# exceeded
find.t <- function(target.service, target.capability, service.max,
                   capability.max) {
    return(
        sqrt(
            find.diff(target.service, service.max)**2 +
                find.diff(target.capability, capability.max)**2
        )
    )
}


options("getSymbols.warning4.0"=FALSE)

currency('USD')
Sys.setenv(TZ="UTC")

symbols <- c("XLB", #SPDR Materials sector
             "XLE", #SPDR Energy sector
             "XLF", #SPDR Financial sector
             "XLP", #SPDR Consumer staples sector
             "XLI", #SPDR Industrial sector
             "XLU", #SPDR Utilities sector
             "XLV", #SPDR Healthcare sector
             "XLK", #SPDR Tech sector
             "XLY", #SPDR Consumer discretionary sector
             "RWR", #SPDR Dow Jones REIT ETF

             "EWJ", #iShares Japan
             #"EWG", #iShares Germany
             "EWU", #iShares UK
             "EWC", #iShares Canada
             "EWY", #iShares South Korea
             "EWA", #iShares Australia
             "EWH", #iShares Hong Kong
             "EWS", #iShares Singapore
             "IYZ", #iShares U.S. Telecom
             "EZU", #iShares MSCI EMU ETF
             "IYR", #iShares U.S. Real Estate
             "EWT", #iShares Taiwan
             "EWZ", #iShares Brazil
             "EFA", #iShares EAFE
             "IGE", #iShares North American Natural Resources
             "EPP", #iShares Pacific Ex Japan
             "LQD", #iShares Investment Grade Corporate Bonds
             "SHY", #iShares 1-3 year TBonds
             "IEF", #iShares 3-7 year TBonds
             "TLT" #iShares 20+ year Bonds
)

#SPDR ETFs first, iShares ETFs afterwards
if(!"XLB" %in% ls()) {
  suppressMessages(getSymbols(symbols, from=from, to=to, src="yahoo", adjust=TRUE))
}


rm(list=ls())
library(plyr)
library(dplyr)
library(ggplot2)
library(tidyr)
library(ggpubr)
library(readxl)
library(stats)
library(tibble)
library(reshape)
library(xlsx)

setwd("/Users/ChatNoir/Projects/Squam/Graphs/")

# Read in data
dfmid <- read_excel("/Users/chatnoir/Projects/Squam/Graphs/Tables/CombinedSchmoosh_2021.xlsx")
df <- dfmid %>%  mutate(Sample = sub('quant', '', Sample))
mdf <- data.frame(Sample=character(0),Hypothesis=character(),corr.eff=numeric(0),pRand=numeric(0))

load("/Users/chatnoir/Projects/Squam/scripts_ch1/Graphing/DataFiles/corsubsample")

results <- results %>% filter(Sample != "all")

# Remove non subsampled values

mid <- df %>% filter(Sample != "all")

hyps <- c('TvS','AIvSA', 'AIvSI','SAvSI')
subs <- c('80m','60m','80mb','60mb')
l1 <- 2000
l2 <- 2000

for (h in hyps) {
  for (s in subs){
    if (h == 'TvS'){
      l <- l1
    }else{
      l <- l2}
    n <- results %>% filter(Hypothesis == h) %>% filter(Loci == l)
    m <- mid %>% filter(Hypothesis == h) %>% filter(Sample == s)
    e <- m$corr.eff
    p.s <- sum(abs(n$corr.eff) >= abs(e)) / length(n$corr.eff)
    a <- data.frame(Sample=s,Hypothesis=h,corr.eff=e,pRand=p.s)
    mdf <- rbind(mdf,a)
  }
}

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

# Save ---------------------------------------------- Save --------------------------------------------------------------------------------------------------------

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

library(xlsx)

fname <- paste("/Users/ChatNoir/Projects/Squam/Graphs/Tables/Combined_corr_rand_pvals_mmb_2021.xlsx",sep='')

write.xlsx2(as.data.frame(mdf), file=fname, row.names=FALSE)


library(ggplot2); library(dplyr): library(readr)

# read in the data

clean <- read_r('train_cleaned.csv')

num_featrs <- c('LotFrontage', 'LotArea' ,'YearBuilt', 'YearRemodAdd',
                'MasVnrArea','BsmtFinSF1','BsmtUnfSF', 'TotalBsmtSF','1stFlrSF',
                '2ndFlrSF','GrLivArea',
                'TotRmsAbvGrd','GarageArea', 'WoodDeckSF', 'OpenPorchSF',
                'EnclosedPorch','PoolArea','MiscValue')

y <- select(poly_data, 'SalePrice')
scatter_plots <- function(df, feat) {
  df  %>%
    ggplot(aes(feat, df$SalePrice)) + facet_wrap(~ feat, scales = "free") +
    theme(legend.position = "none") + labs(x = "", y = "")
}

box_plots <- function(df) {

}


# See https://www.ibm.com/developerworks/community/blogs/kevgrig/entry/graphing_arbitrary_data_from_the_command_line_using_r?lang=en
# Sample data in /sampledata/ihs/mpmstats
# Prereq: > install.packages(c("xts", "xtsExtra", "zoo", "txtplot"), repos=c("http://cran.us.r-project.org","http://R-Forge.R-project.org"))
# Convert error_log to CSV: OUTPUT=error_log.csv; echo Time,rdy,bsy,rd,wr,ka,log,dns,cls > ${OUTPUT}; grep "mpmstats: rdy " error_log | sed -n "s/\[[^ ]\+ \([^ ]\+\) \([0-9]\+\) \([^ ]\+\) \([0-9]\+\)\] \(.*\)/\1:\2:\4:\3 \5/p" | tr ' ' ',' | cut -d "," -f 1,5,7,9,11,13,15,17,19 >> ${OUTPUT};
# Run: $ cat error_log.csv | R --silent --no-save -f mpmstats.r 2>/dev/null

require(xts, warn.conflicts=FALSE)
require(xtsExtra, warn.conflicts=FALSE)
require(zoo, warn.conflicts=FALSE)
require(txtplot, warn.conflicts=FALSE)

pngfile = "output.png"
pngwidth = 600
asciiwidth = 120

mpmtime = function(x, format) { as.POSIXct(paste(as.Date(substr(as.character(x),1,11), format="%b:%d:%Y"), substr(as.character(x),13,20), sep=" "), format=format, tz="UTC") }
data = as.xts(read.zoo(file="stdin", format = "%Y-%m-%d %H:%M:%S", header=TRUE, sep=",", FUN = mpmtime))
x = sapply(index(data), function(time) {as.numeric(strftime(time, format = "%H%M"))})
txtplot(x, data[,2], width=asciiwidth, xlab="Time", ylab="mpmstats bsy")
png(pngfile, width=pngwidth)
plot.xts(data, main="mpmstats", minor.ticks=FALSE, yax.loc="left", auto.grid=TRUE, ylim="fixed", nc=2)


library(ggplot2)

set.seed(123)
d <- data.frame(y=rnorm(1000))

breaks <- hist(d$y, breaks=30, plot=FALSE)$breaks

p1 <-
ggplot(d, aes(y)) +
geom_histogram(breaks=breaks, color="black", size=0.5, fill=NA, aes(y=100*(..count..)/sum(..count..))) +
scale_x_continuous(expand=expand_scale(mult=c(0,0.01))) +
scale_y_continuous(expand=expand_scale(mult=c(0,0.01))) +
ylab("Percent") +
theme_classic(base_size=10) +
theme(
line = element_line(lineend="square"),
axis.text = element_text(size=rel(0.8), color="black"),
axis.ticks = element_line(color="black")
)

#ggsave("p1.pdf", p1, width=6, height=5, units="cm")
ggsave("p1.tiff", p1, width=6, height=5, units="cm", compression="lzw")


plot_mean_bar <- function (data, suffix, title, metric_label, metric_unit) {
    log_info ('Plotting "{metric_label}" mean bar plot for "{suffix}" ...')
    nice <- ggplot (data) +
        geom_col (aes (x = vm, y = avg, fill = vm), color = 'black') +
        geom_errorbar (aes (x = vm, ymin = lo, ymax = hi), width = 0.5) +
        facet_wrap (vars (benchmark), nrow = PLOT_ROWS, scales = 'free_y') +
        theme (legend.position = 'none', axis.text.x = element_text (angle = 90, vjust = 0.5, hjust = 1)) +
        labs (
            x = NULL,
            y = sprintf ('Mean single repetition %s [%s]', metric_label, metric_unit),
            title = title) +
        scale_fill_brewer (palette = 'Blues', type = 'qual')
    plot_save (nice, c ('mean', 'bar', suffix))
}


library(flume)
library(data.table)
files = list.files("ex2/res", full.names = TRUE)
fits = lapply(files, readRDS)

## for all metrics, average over the last 30 time steps

## network-scale table
# occupancy is the average proportion of sites with at least one species
# alpha | sps_meta | gamma_meta | sps_actual | occ_actual | gamma_actual | EF

## node-scale table
# alpha | sps_meta | gamma_meta | sps_actual | richness | EF

f = fits[[1]]
fn = files[1]

n = f[["networks"]][[1]]

network_stats = function(n, fn) {
	pat = ".+alpha-([0-9\\.]+)_sp-([1-5]+).rds"
	sp_hist = state(n, "species", history = TRUE)[32:61]
	sps_meta = sub(pat, "\\2", fn)
	sp_counts = colSums(Reduce(`+`, sp_hist))
	occ_sites = lapply(sp_hist, \(x) rowSums(x) > 0)
	ef_hist = state(n, "reaction", history = TRUE)[32:61]
	data.table(
		alpha = as.numeric(sub(pat, "\\1", fn)),
		sps_meta = sps_meta,
		gamma_meta = nchar(sps_meta),
		sps_actual = paste(which(sp_counts != 0), collapse = ""),
		occ_actual = mean(sapply(occ_sites, \(x) sum(x) / length(x))),
		gamma_actual = sum(sp_counts != 0),
		EF = sum(Reduce(`+`, ef_hist)))
}

node_stats = function(n, fn) {
	pat = ".+alpha-([0-9\\.]+)_sp-([1-5]+).rds"
	sps_meta = sub(pat, "\\2", fn)
	sp_hist = state(n, "species", history = TRUE)[32:61]
	sp_counts = Reduce(`+`, sp_hist)
	ef_hist = state(n, "reaction", history = TRUE)[32:61]

	data.table(
		alpha = as.numeric(sub(pat, "\\1", fn)),
		sps_meta = sps_meta,
		gamma_meta = nchar(sps_meta),
		gamma_actual = sum(sp_counts != 0),
		sps_actual = apply(sp_counts, 1, \(x) paste(which(x != 0), collapse = "")),
		richness = apply(sp_counts, 1, \(x) sum(x != 0)),
		EF = Reduce(`+`, ef_hist))
}

network_ef = rbindlist(mapply(\(f, fn) {
	rbindlist(lapply(f[["networks"]], network_stats, fn = fn))
}, fits, files, SIMPLIFY = FALSE))

ggplot(network_ef) + geom_boxplot(aes(x = factor(alpha), y = -1*EF)) + facet_wrap(~gamma_meta) +
	theme_minimal() + xlab("Dispersal ability") + ylab("Resource flux (g • m^-3 • month)")


#' Creates a new ARTMAP network.
#'
#' This function creates a new ARTMAP network with the specified number
#' features and classes. The network is created to expand the number of
#' categories as needed. The vigilance parameter defaults to 0.75.
#' The initial number of categories is set to 1. The maximum number
#' of categories defaults to 100. The bias defaults to 0.000001, the
#' number of epochs defaults to 100, and the learning rate defaults
#' to 1.0 (fast-learning).
#' @title ARTMAP_Create_Network
#' @param numFeatures Number of features that the network expects of the input data. Must be a positive integer.
#' @param numClasses Number of classes that exist for the supervisory signal. Must be a positive integer greater than 1.
#' @param maxNumCategories Maximum number of categories that can be activated during the training process. Defaults to 1000.
#' @param vigilance Vigilance parameter that defines the minimum similarity allowed between the input pattern and the weights. Defaults to 0.75.
#' @param bias Constant that is used to differentiate between very similar category activation values. Defaults to 0.000001
#' @param numEpochs Maximum number of training iterations allowed. Defaults to 100.
#' @param learningRate Learning rate. Defaults to 1.
#' @return Structure that holds all of the information for the network. It must be passed into both ARTMAP_LEARN() and
#' ARTMAP_CLASSIFY(). The fields of this structure are numFeatures, numCategories, maxNumCategories, numClasses, weight
#' (an initialized weight vector with the right dimensions), mapField (an initialized map field with the right dimensions),
#' vigilance, bias, numEpochs, neededEpochs (the number of epochs needed in the last training) and learningRate.
#' @export
ARTMAP_Create_Network=function(numFeatures, numClasses,
                               maxNumCategories = 1000, vigilance=0.75,
                                bias=0.000001, numEpochs=100, learningRate=1.0)
{
  if(is.null(numFeatures) || is.null(numClasses))
  {
    stop('You must specify the number of features and the number of classes.');
  }

  # Check the ranges of the input parameters.
  numFeatures = round(numFeatures);
  if(numFeatures < 1)
  {
    stop('The number of features must be a positive integer.');
  }
  numClasses = round(numClasses);
  if(numClasses < 2)
  {
    stop('The number of classes must be a positive integer greater than 1.');
  }

  # Create and initialize the weight matrix.
  weight = matrix(1,0,numFeatures);

  # Create and initialize the map field.
  mapField = matrix(0,0,1);

  # Create the structure and return.
  artmap_network = list("numFeatures"= numFeatures, "numCategories" = 0, "maxNumCategories" = maxNumCategories,
                          "numClasses"=numClasses, "weight"=weight, "mapField"=mapField,
                          "vigilance"=vigilance, "bias"=bias, "numEpochs"=numEpochs,
                          "neededEpochs"=0,"learningRate"=learningRate);

  return(artmap_network);
}


#@author: Hoofar Pourzand
#This file is copyright protected - do not redistribute
#For R style exercise https://google.github.io/styleguide/Rguide.xml

View(mtcars)

mt1 = mtcars[mtcars$mpg>20,c('gear','mpg')]
View(mt1)

mt2 = aggregate(. ~ gear,mtcars[mtcars$mpg>20,c('gear','mpg')],mean)
View(mt2)

mt3 = subset(aggregate(. ~ gear,mtcars[mtcars$mpg>20,c('gear','mpg')],mean), mpg>25)
View(mt3)


#############################################################
# R script for building multiple models and their evaluation
#############################################################
library(caret)
library(pROC)

# parallel execution - Windows
#library(doParallel);
#cl <- makeCluster(4); #4 cores
#registerDoParallel(cl)

# parallel execution - Linux
#library(doMC)
#registerDoMC(cores = 4)

#####################################
# load the dataset
#####################################
#i.i.d assumption
#hdd_iid_df <- read.csv("D:\\NUS\\IVLE\\DATA MINING METHODOLOGY AND METHODS\\CA\\DM\\data\\hdd_iid.csv", header=TRUE)

# reusing same name only; the below file is in time series format!
#EMA
hdd_iid_df <- read.csv("D:\\NUS\\IVLE\\DATA MINING METHODOLOGY AND METHODS\\CA\\DM\\data\\ewa_30.csv", header=TRUE)

# tsfresh
#hdd_iid_df <- read.csv("D:\\NUS\\IVLE\\DATA MINING METHODOLOGY AND METHODS\\CA\\DM\\data\\features_filtered_direct_7days.csv", header=TRUE)

# data type fomatting for target
hdd_iid_df$failure <- as.factor(hdd_iid_df$failure)

#####################################
# split into train and test datasets
#####################################
#split = 0.80
split = 0.70
#split = 0.50

trainIndex <- createDataPartition(hdd_iid_df$failure, p=split, list=FALSE)
hdd_train <- hdd_iid_df[ trainIndex,]
hdd_test <- hdd_iid_df[-trainIndex,]

# create copies for preprocessing step using PCA

# EMA
hdd_train_without_target <- hdd_train[,3:18]
hdd_train_with_target <- hdd_train[,c(1,3:18)] # column 1 is the target 'failure'

# 3 days
#hdd_train_without_target <- hdd_train[,3:855]
#hdd_train_with_target <- hdd_train[,c(1,3:855)] # column 1 is the target 'failure'

# 7 days
#hdd_train_without_target <- hdd_train[,3:1407]
#hdd_train_with_target <- hdd_train[,c(1,3:1407)] # column 1 is the target 'failure'

# 15 days
#hdd_train_without_target <- hdd_train[,3:1966]
#hdd_train_with_target <- hdd_train[,c(1,3:1966)] # column 1 is the target 'failure'

# 30 days
#hdd_train_without_target <- hdd_train[,3:2250]
#hdd_train_with_target <- hdd_train[,c(1,3:2250)] # column 1 is the target 'failure'

##################################
# cross validation train controls
##################################
train_control_kcv <- trainControl(method="cv", number=5, savePredictions = T, preProcOptions=list(thresh = 0.90))
#train_control_loocv <- trainControl(method="LOOCV")

##################################
# test data preparation
##################################
#x_test <- hdd_test[,3:9] #iid
#y_test <- hdd_test[,2] #iid

# EMA
x_test <- hdd_test[,3:18]

# 3 days
#x_test <- hdd_test[,3:855] #temporal

# 7 days
#x_test <- hdd_test[,3:1407] #temporal

# 15 days
#x_test <- hdd_test[,3:1966] #temporal

# 30 days
#x_test <- hdd_test[,3:2250] #temporal

y_test <- hdd_test[,1] #temporal

##################################
# preprocessing steps
##################################
# PCA by limiting variance threshold = 90% yields 48 Principal Components
preProc  <- preProcess(hdd_train_without_target, method = c("center", "scale", "pca"), thresh=0.90)
# Applying the processing steps to test and generating the Principal Components for test from the PC coefficients
x_test <- predict(preProc, x_test)

# this is the final training set with PCs and target.
# After cross validation is verified, the model will be trained again using this dataset.
hdd_train_final <- predict(preProc, hdd_train_without_target)
hdd_train_final$failure <- hdd_train[,1]

##################################
# train using decision tree model
##################################
# cross validation
# k=5 folds
#model_rpart <- train(failure~ R10_smart_5_raw + R10_smart_184_raw + R10_smart_187_raw + R10_smart_188_raw + R10_smart_198_raw + R10_smart_183_raw + R10_smart_7_raw, data=hdd_train, trControl=train_control_kcv, method = "rpart")
#model_rpart <- train(failure~ R10_smart_5_raw + R10_smart_184_raw + R10_smart_187_raw + R10_smart_188_raw + R10_smart_198_raw + R10_smart_183_raw + R10_smart_7_raw, data=hdd_train, trControl=train_control_loocv, method = "rpart")
model_rpart <- train(failure~., data=hdd_train_with_target, trControl=train_control_kcv, method = "rpart", preProcess=c("center", "scale", "pca"))
print(model_rpart)
roc_rpart<- roc(predictor = as.numeric(model_rpart$pred$pred), response = model_rpart$pred$obs, plot=TRUE, auc=TRUE)

# train using the final trainset and make predictions on test data
model_rpart <- train(failure~., data=hdd_train_final, method = "rpart")
predictions_rpart <- predict(model_rpart, x_test)
# summarize results
confusionMatrix(data=predictions_rpart, reference=y_test, positive="1")

##################################
# train using svm
##################################
# cross validation
# k=5 folds
#model_svmLinear <- train(failure~ R10_smart_5_raw + R10_smart_184_raw + R10_smart_187_raw + R10_smart_188_raw + R10_smart_198_raw + R10_smart_183_raw + R10_smart_7_raw, data=hdd_train, trControl=train_control_kcv, method = "svmLinear")
#model_svmLinear <- train(failure~ R10_smart_5_raw + R10_smart_184_raw + R10_smart_187_raw + R10_smart_188_raw + R10_smart_198_raw + R10_smart_183_raw + R10_smart_7_raw, data=hdd_train, trControl=train_control_loocv, method = "svmLinear")
model_svmLinear <- train(failure~., data=hdd_train_with_target, trControl=train_control_kcv, method = "svmLinear")
print(model_svmLinear)
roc_svmLinear<- roc(predictor = as.numeric(model_svmLinear$pred$pred), response = model_svmLinear$pred$obs, plot=TRUE, auc=TRUE)

# train using the final trainset and make predictions on test data
model_svmLinear <- train(failure~., data=hdd_train_final, method = "svmLinear")
predictions_svmLinear <- predict(model_svmLinear, x_test)
# summarize results
confusionMatrix(data=predictions_svmLinear, reference=y_test, positive="1")

##################################
# train using Naive Bayes
##################################
# cross validation
# k=5 folds
#model_nb <- train(failure~ R10_smart_5_raw + R10_smart_184_raw + R10_smart_187_raw + R10_smart_188_raw + R10_smart_198_raw + R10_smart_183_raw + R10_smart_7_raw, data=hdd_train, trControl=train_control_kcv, method = "nb")
#model_nb <- train(failure~ R10_smart_5_raw + R10_smart_184_raw + R10_smart_187_raw + R10_smart_188_raw + R10_smart_198_raw + R10_smart_183_raw + R10_smart_7_raw, data=hdd_train, trControl=train_control_loocv, method = "nb")
model_nb <- train(failure~., data=hdd_train_with_target, trControl=train_control_kcv, method = "nb")
print(model_nb)
roc_nb<- roc(predictor = as.numeric(model_nb$pred$pred), response = model_nb$pred$obs, plot=TRUE, auc=TRUE)

# train using the final trainset and make predictions on test data
model_nb <- train(failure~., data=hdd_train_final, method = "nb")
predictions_nb <- predict(model_nb, x_test)
# summarize results
confusionMatrix(data=predictions_nb, reference=y_test, positive="1")

##################################
# train using Random Forest
##################################
# cross validation
# k=5 folds
# number of trees = 51
ntree = 51
#model_rf <- train(failure~ R10_smart_5_raw + R10_smart_184_raw + R10_smart_187_raw + R10_smart_188_raw + R10_smart_198_raw + R10_smart_183_raw + R10_smart_7_raw, data=hdd_train, method="rf", trControl=train_control_kcv, ntree=ntree)
#model_rf <- train(failure~ R10_smart_5_raw + R10_smart_184_raw + R10_smart_187_raw + R10_smart_188_raw + R10_smart_198_raw + R10_smart_183_raw + R10_smart_7_raw, data=hdd_train, method="rf", trControl=train_control_loocv, ntree=ntree)
model_rf <- train(failure~., data=hdd_train_with_target, method="rf", trControl=train_control_kcv, ntree=ntree)
print(model_rf)
roc_rf<- roc(predictor = as.numeric(model_rf$pred$pred), response = model_rf$pred$obs, plot=TRUE, auc=TRUE)

# train using the final trainset and make predictions on test data
model_rf <- train(failure~., data=hdd_train_final, method = "rf")
predictions_rf <- predict(model_rf, x_test)
# summarize results
confusionMatrix(data=predictions_rf, reference=y_test, positive="1")

##################################
# train using Logistic Regression
##################################
# cross validation
# k=5 folds
#model_logit <- train(failure~ R10_smart_5_raw + R10_smart_184_raw + R10_smart_187_raw + R10_smart_188_raw + R10_smart_198_raw + R10_smart_183_raw + R10_smart_7_raw, data=hdd_train, method="glm", family="binomial", trControl=train_control_kcv)
#model_logit <- train(failure~ R10_smart_5_raw + R10_smart_184_raw + R10_smart_187_raw + R10_smart_188_raw + R10_smart_198_raw + R10_smart_183_raw + R10_smart_7_raw, data=hdd_train, method="glm", family="binomial", trControl=train_control_loocv)
model_logit <- train(failure~., data=hdd_train_with_target, method="glm", family="binomial", trControl=train_control_kcv)
print(model_logit)
roc_logit<- roc(predictor = as.numeric(model_logit$pred$pred), response = model_logit$pred$obs, plot=TRUE, auc=TRUE)

# train using the final trainset and make predictions on test data
model_logit <- train(failure~., data=hdd_train_final, method="glm", family="binomial")
predictions_logit <- predict(model_logit, x_test)
# summarize results
confusionMatrix(data=predictions_logit, reference=y_test, positive="1")

##################################
# train using XGBoost Linear
##################################
# cross validation
# k=5 folds
model_xgb <- train(failure~., data=hdd_train_with_target, method="xgbLinear", trControl=train_control_kcv)
print(model_xgb)
roc_xgb<- roc(predictor = as.numeric(model_xgb$pred$pred), response = model_xgb$pred$obs, plot=TRUE, auc=TRUE)

# train using the final trainset and make predictions on test data
model_xgb <- train(failure~., data=hdd_train_final, method="xgbLinear")
predictions_xgb <- predict(model_xgb, x_test)
# summarize results
confusionMatrix(data=predictions_xgb, reference=y_test, positive="1")

##########################################################
# Plot ROC with Area Under the Curve for all models
##########################################################
plot(roc_rf, col="blue")
plot(roc_logit, add=TRUE, col="red")
plot(roc_rpart, add=TRUE, col="green")
plot(roc_svmLinear, add=TRUE, col="black")
plot(roc_nb, add=TRUE, col="orange")
plot(roc_xgb, add=TRUE, col="yellow")
op <- par(cex = 0.7)
legend("bottomright", legend = c("RF", "Logit", "DecisionTree", "SVM-Linear","NaiveBayes", "XGBoost"), col = c("blue", "red", "green", "black","orange", "yellow"), lty = 1)
legend("topright", legend = c(paste("RF: ", round(roc_rf$auc, digits = 4), sep=" "),paste("Logit: ", round(roc_logit$auc, digits = 4)),paste("DecisionTree: ", round(roc_rpart$auc, digits = 4)),paste("SVM-Linear: ", round(roc_svmLinear$auc, digits = 4)),paste("NB: ", round(roc_nb$auc, digits = 4)), paste("XGBoost: ", round(roc_xgb$auc, digits = 4)), sep=""))

# stop and deregister the parallel execution allocation - Windows
#stopCluster(cl)
#registerDoSEQ()


#!/usr/bin/Rscript --vanilla
#
# distrib.r:
#   utility to plot distribution/density of a numeric data-set column
#
#   Usage:
#       distrib.r data_file ["optional chart title string"]
#   where data_file contains the numeric vector, a number per line.
#
suppressPackageStartupMessages(library(ggplot2))

ratio = 1.61803398875
W = 4
H = W / ratio
DPI = 200
FONTSIZE = 9
MyGray = 'grey50'

title.theme   = element_text(family="FreeSans", face="bold.italic",
                            size=FONTSIZE-2, hjust=0.5)
x.title.theme = element_text(family="FreeSans", face="bold.italic",
                            size=FONTSIZE-2, vjust=-0.1)
y.title.theme = element_text(family="FreeSans", face="bold.italic",
                           size=FONTSIZE-2, angle=90, vjust=0.2)
x.axis.theme  = element_text(family="FreeSans", face="bold",
                            size=FONTSIZE-2, color=MyGray)
y.axis.theme  = element_text(family="FreeSans", face="bold",
                            size=FONTSIZE-2, color=MyGray)
legend.theme  = element_text(family="FreeSans", face="bold.italic",
                            size=FONTSIZE-1, color="black")

eprintf <- function(...) cat(sprintf(...), sep='', file=stderr())

argv <- commandArgs(trailingOnly = TRUE)

csvfile <- argv[1]
title <- ifelse(! is.na(argv[2]),
                argv[2],
                'vw demo: random expression distribution')
Ys   <- read.csv(csvfile, header=F, col.names='Ys')

d <- data.frame(Ys=Ys)

Y_labels <- function(yrange) {
    the.min <- as.integer(floor(yrange[1]))
    the.max <- as.integer(ceiling(yrange[2] + 1))
    seq(from=the.min, to=the.max, by=1)
}

# geom_histogram(binwidth=.5, alpha=.5, position="identity")
# geom_histogram(fill='#3377ff',
#        binwidth=.01, alpha=.4, stat='density') +
g <- ggplot(data=d, aes(x=Ys)) +
        geom_density(fill='#3377ff', alpha=0.4, lwd=0.2) +
        scale_x_continuous(breaks=Y_labels(range(Ys))) +
        ggtitle(title) +
        xlab(NULL) +
        theme(
            plot.title=title.theme,
            axis.title.y=y.title.theme,
            axis.title.x=x.title.theme,
            axis.text.x=x.axis.theme,
            axis.text.y=y.axis.theme
        )

pngfile <- sprintf("%s.density.png", csvfile)
ggsave(g, file=pngfile, width=W, height=H, dpi=DPI)


############################################################
# R script 2 of: Birds exposed to physiological stress     #
# post-breeding engage in stress-reducing social           #
# interactions in winter flocks                            #

# Running the main analysis and making the figures 3, 4, 5 #
# author: Lionel Hertzog                                   #
############################################################

# set wd to the local position of the github repo
setwd("~/PostDoc_Ghent/Feeder_stuff/network_stress/")

# load packages
library(tidyverse)
library(gridExtra)

# load data
network_dat <- read.csv("data/network_dat.csv")

# 1. Fit the centrality ~ cort_orig models
## some data points were dropped to ensure that
## model assumptions were met
m_1 <- lm(betw ~ cort_orig + sex + age + barl_orig, network_dat[-c(153),]) # males have higher betw slight effect of cort
m_2 <- lm(degree ~ cort_orig + sex + age + barl_orig, network_dat[-c(153),]) # effect of cort
m_3 <- lm(eigen ~ cort_orig + sex + age + barl_orig, network_dat[-c(153),]) # trend for positive effect of cort on centrality
m_4 <- lm(strength ~ cort_orig + sex + age + barl_orig, network_dat[-c(153),]) # effect of cort

## save these models
m_orig <- list(betw = m_1, degree = m_2, eigen = m_3, strength = m_4)
saveRDS(m_orig, "models/m_orig.rds")

## make the figure
### the data frame to derive the prediction from
newdat <- expand.grid(cort_orig = seq(0,0.15,length=10), sex = "f", age = "1Y",barl_orig = 14.26)
### betweenness
newdat$betw <- predict(m_1, newdata = newdat, se.fit = TRUE)$fit + mean(c(0,coef(m_1)[3])) + mean(c(0,coef(m_1)[4])) # remove sex and age effect
newdat$se_betw <- predict(m_1, newdata = newdat, se.fit = TRUE)$se.fit
### degree
newdat$degree <- predict(m_2, newdata = newdat, se.fit = TRUE)$fit + mean(c(0,coef(m_2)[3])) + mean(c(0,coef(m_2)[4])) # remove sex and age effect
newdat$se_degree <- predict(m_2, newdata = newdat, se.fit = TRUE)$se.fit
### eigenvector
newdat$eigen <- predict(m_3, newdata = newdat, se.fit = TRUE)$fit + mean(c(0,coef(m_3)[3])) + mean(c(0,coef(m_3)[4])) # remove sex and age effect
newdat$se_eigen <- predict(m_3, newdata = newdat, se.fit = TRUE)$se.fit
### strength
newdat$strength <- predict(m_4, newdata = newdat, se.fit = TRUE)$fit + mean(c(0,coef(m_4)[3])) + mean(c(0,coef(m_4)[4])) # remove sex and age effect
newdat$se_strength <- predict(m_4, newdata = newdat, se.fit = TRUE)$se.fit

### the theme for all plots
theme_gg <- theme(panel.background = element_blank(), axis.line = element_line())

### the plots
gg_betw <- ggplot(newdat, aes(x=cort_orig,y=betw)) +
  geom_line() +
  geom_ribbon(alpha = 0.1,aes(ymin=betw - 1.96*se_betw, ymax = betw + 1.96*se_betw)) +
  geom_point(data=network_dat[-153,]) +
  labs(x="", y="Betweenness centrality") +
  theme_gg

gg_degree <- ggplot(newdat, aes(x=cort_orig,y=degree)) +
  geom_line() +
  geom_ribbon(alpha = 0.1,aes(ymin=degree - 1.96*se_degree, ymax = degree + 1.96*se_degree)) +
  geom_point(data=network_dat[-153,]) +
  labs(x="", y="Degree") +
  theme_gg

gg_eigen <- ggplot(newdat, aes(x=cort_orig,y=eigen)) +
  geom_line() +
  geom_ribbon(alpha = 0.1,aes(ymin=eigen - 1.96*se_eigen, ymax = eigen + 1.96*se_eigen)) +
  geom_point(data=network_dat[-153,]) +
  labs(x="", y="Eigenvector centrality") +
  theme_gg

gg_strength <- ggplot(newdat, aes(x=cort_orig,y=strength)) +
  geom_line() +
  geom_ribbon(alpha = 0.1,aes(ymin=strength - 1.96*se_strength, ymax = strength + 1.96*se_strength)) +
  geom_point(data=network_dat[-153,]) +
  labs(x="", y="Strength") +
  theme_gg

### put this all together
gg_orig <- grid.arrange(gg_eigen,gg_betw,gg_degree,gg_strength,bottom="Original feather CORT (\U003BCg)")
ggsave("figures/fig_03.png",gg_orig)

# 1.2 Fit the centrality ~ cort_orig models without the pullis
# some individuals were dropped to meet model requirements
m_1 <- lm(betw ~ cort_orig + sex + barl_orig, network_dat[-153,], subset = age == "AD") # males have higher betw slight effect of cort
m_2 <- lm(degree ~ cort_orig + sex + barl_orig, network_dat[-153,], subset = age == "AD") # effect of cort
m_3 <- lm(eigen ~ cort_orig + sex + barl_orig, network_dat[-c(153),], subset = age == "AD") # trend for positive effect of cort on centrality
m_4 <- lm(strength ~ cort_orig + sex + barl_orig, network_dat[-c(153),], subset = age == "AD") # effect of cort

## save these models
m_orig_ad <- list(betw = m_1, degree = m_2, eigen = m_3, strength = m_4)
saveRDS(m_orig_ad, "models/m_orig_ad.rds")

# 1.3 Fit the centrality ~ cort_orig models with feeder visits
m_1 <- lm(betw ~ cort_orig + sex + age + barl_orig + feeding_freq, network_dat[-153,]) # males have higher betw slight effect of cort
m_2 <- lm(degree ~ cort_orig + sex + age + barl_orig + feeding_freq, network_dat[-153,]) # effect of cort
m_3 <- lm(eigen ~ cort_orig + sex + age + barl_orig + feeding_freq, network_dat[-c(153),]) # trend for positive effect of cort on centrality
m_4 <- lm(strength ~ cort_orig + sex + age + barl_orig + feeding_freq, network_dat[-c(153),]) # effect of cort

m_orig_feeding <- list(betw = m_1, degree = m_2, eigen = m_3, strength = m_4)
saveRDS(m_orig_feeding, "models/m_orig_feeding.rds")

# 2. Fit the cort_induced ~ centrality models
## some data points were dropped to ensure that
## model assumptions were met
m_5 <- glm(cort_ind + 0.0001 ~ betw + sex + age + barl_ind, network_dat[-272,], family = Gamma(link="log"))
m_6 <- glm(cort_ind + 0.0001 ~ degree + sex + age + barl_ind, network_dat[-272,], family = Gamma(link="log"))
m_7 <- glm(cort_ind + 0.0001 ~ eigen + sex + age + barl_ind, network_dat[-c(25,272),], family = Gamma(link="log"))
m_8 <- glm(cort_ind + 0.0001 ~ strength + sex + age + barl_ind, network_dat[-272,], family = Gamma(link="log"))

## save the models
m_ind <- list(betw = m_5, degree = m_6, eigen = m_7, strength = m_8)
saveRDS(m_ind, "models/m_ind.rds")

## plot the predicted responses
### betw
newdat <- expand.grid(betw = seq(0,8.6,length=10), sex = "f", age = "AD",barl_ind = 11.55)
newdat$cort_ind <- predict(m_ind$betw, newdata = newdat, se.fit = TRUE)$fit + mean(c(0,coef(m_ind$betw)[3])) + mean(c(0,coef(m_ind$betw)[4]))
newdat$se <- predict(m_ind$betw, newdata = newdat, se.fit = TRUE)$se.fit
newdat$LCI <- exp(newdat$cort_ind - 1.96 * newdat$se)
newdat$UCI <- exp(newdat$cort_ind + 1.96 * newdat$se)
newdat$cort_ind <- exp(newdat$cort_ind)

gg_betw <- ggplot(newdat, aes(x=betw,y=cort_ind)) +
  geom_line() +
  geom_ribbon(alpha = 0.1,aes(ymin=LCI, ymax = UCI)) +
  geom_point(data=network_dat[-272,]) +
  labs(x="Betwenness centrality", y="Induced feather CORT (\U003BCg)") +
  ylim(c(0,2)) +
  theme_gg

### degree
newdat <- expand.grid(degree = seq(42,139,length=10), sex = "f", age = "AD",barl_ind = 11.55)
newdat$cort_ind <- predict(m_ind$degree, newdata = newdat, se.fit = TRUE)$fit + mean(c(0,coef(m_ind$degree)[3])) + mean(c(0,coef(m_ind$degree)[4]))
newdat$se <- predict(m_ind$degree, newdata = newdat, se.fit = TRUE)$se.fit
newdat$LCI <- exp(newdat$cort_ind - 1.96 * newdat$se)
newdat$UCI <- exp(newdat$cort_ind + 1.96 * newdat$se)
newdat$cort_ind <- exp(newdat$cort_ind)

gg_degree <- ggplot(newdat, aes(x=degree,y=cort_ind)) +
  geom_line() +
  geom_ribbon(alpha = 0.1,aes(ymin=LCI, ymax = UCI)) +
  geom_point(data=network_dat[-272,]) +
  labs(x="Degree", y="Induced feather CORT (\U003BCg)") +
  xlim(c(40,140)) +
  ylim(c(0,2)) +
  theme_gg

### eigenvector
newdat <- expand.grid(eigen = seq(0,1,length=10), sex = "f", age = "AD",barl_ind = 11.55)
newdat$cort_ind <- predict(m_ind$eigen, newdata = newdat, se.fit = TRUE)$fit + mean(c(0,coef(m_ind$eigen)[3])) + mean(c(0,coef(m_ind$eigen)[4]))
newdat$se <- predict(m_ind$eigen, newdata = newdat, se.fit = TRUE)$se.fit
newdat$LCI <- exp(newdat$cort_ind - 1.96 * newdat$se)
newdat$UCI <- exp(newdat$cort_ind + 1.96 * newdat$se)
newdat$cort_ind <- exp(newdat$cort_ind)

gg_eigen <- ggplot(newdat, aes(x=eigen,y=cort_ind)) +
  geom_line() +
  geom_ribbon(alpha = 0.1,aes(ymin=LCI, ymax = UCI)) +
  geom_point(data=network_dat[-c(25,272,279),]) +
  labs(x="Eigenvector centrality", y="Induced feather CORT (\U003BCg)") +
  ylim(c(0,2)) +
  theme_gg

### strength
newdat <- expand.grid(strength = seq(0,19,length=10), sex = "f", age = "AD",barl_ind = 11.55)
newdat$cort_ind <- predict(m_ind$strength, newdata = newdat, se.fit = TRUE)$fit + mean(c(0,coef(m_ind$strength)[3])) + mean(c(0,coef(m_ind$strength)[4]))
newdat$se <- predict(m_ind$strength, newdata = newdat, se.fit = TRUE)$se.fit
newdat$LCI <- exp(newdat$cort_ind - 1.96 * newdat$se)
newdat$UCI <- exp(newdat$cort_ind + 1.96 * newdat$se)
newdat$cort_ind <- exp(newdat$cort_ind)

gg_strength <- ggplot(newdat, aes(x=strength,y=cort_ind)) +
  geom_line() +
  geom_ribbon(alpha = 0.1,aes(ymin=LCI, ymax = UCI)) +
  geom_point(data=network_dat[-c(272),]) +
  labs(x="Strength", y="Induced feather CORT (\U003BCg)") +
  ylim(c(0,2)) +
  theme_gg

gg_ind <- grid.arrange(gg_eigen,gg_betw,gg_degree,gg_strength)
ggsave("figures/fig_04.png",gg_ind)

# 3. Fit the feeding frequency ~ network centrality models
m_9 <- lm(feeding_freq ~ betw + sex + age, network_dat)
m_10 <- lm(feeding_freq ~ degree + sex + age, network_dat)
m_11 <- lm(feeding_freq ~ eigen + sex + age, network_dat)
m_12 <- lm(feeding_freq ~ strength + sex + age, network_dat)

## save these models
m_feed <- list(betw = m_9, degree = m_10, eigen = m_11, strength = m_12)
saveRDS(m_feed, "models/m_feed.rds")

## plot (also with prediction interval)
### betwenness
newdat <- data.frame(betw = seq(min(network_dat$betw,na.rm=TRUE),max(network_dat$betw,na.rm=TRUE),length.out = 10), age = "1Y", sex = "f")
pred <- predict(m_9,newdat,interval = "confidence")
newdat <- cbind(newdat, pred)
names(newdat)[4] <- "feeding_freq"
pred_2 <- predict(m_9,newdat,interval="prediction")
colnames(pred_2)[2:3] <- c("P_lwr","P_upr")
newdat <- cbind(newdat, pred_2[,2:3])
cst <- mean(c(0,coef(m_9)[3])) + mean(c(0,coef(m_9)[4])) # constant to average out sex and age effects
newdat[,4:8] <- newdat[,4:8] + cst

gg_betw <- ggplot(network_dat,aes(x=betw,y=feeding_freq)) +
  geom_point() +
  geom_ribbon(data=newdat,aes(ymin=P_lwr,ymax=P_upr),color=NA,alpha=0.08) + # prediction interval
  geom_ribbon(data=newdat,aes(ymin=lwr,ymax=upr),color=NA,alpha=0.2) + # confidence interval
  geom_line(data=newdat) +
  labs(x="Betweenness centrality", y = "Feeder visits") +
  theme_gg

### eigenvector
newdat <- data.frame(eigen = seq(min(network_dat$eigen,na.rm=TRUE),max(network_dat$eigen,na.rm=TRUE),length.out = 10), age = "1Y", sex = "f")
pred <- predict(m_11,newdat,interval = "confidence")
newdat <- cbind(newdat, pred)
names(newdat)[4] <- "feeding_freq"
pred_2 <- predict(m_11,newdat,interval="prediction")
colnames(pred_2)[2:3] <- c("P_lwr","P_upr")
newdat <- cbind(newdat, pred_2[,2:3])
cst <- mean(c(0,coef(m_11)[3])) + mean(c(0,coef(m_11)[4])) # constant to average out sex and age effects
newdat[,4:8] <- newdat[,4:8] + cst

gg_eigen <- ggplot(network_dat,aes(x=eigen,y=feeding_freq)) +
  geom_point() +
  geom_ribbon(data=newdat,aes(ymin=P_lwr,ymax=P_upr),color=NA,alpha=0.08) + # prediction interval
  geom_ribbon(data=newdat,aes(ymin=lwr,ymax=upr),color=NA,alpha=0.2) + # confidence interval
  geom_line(data=newdat) +
  labs(x="Eigenvector centrality", y = "Feeder visits") +
  theme_gg

### degree
newdat <- data.frame(degree = seq(min(network_dat$degree,na.rm=TRUE),max(network_dat$degree,na.rm=TRUE),length.out = 10), age = "1Y", sex = "f")
pred <- predict(m_10,newdat,interval = "confidence")
newdat <- cbind(newdat, pred)
names(newdat)[4] <- "feeding_freq"
pred_2 <- predict(m_10,newdat,interval="prediction")
colnames(pred_2)[2:3] <- c("P_lwr","P_upr")
newdat <- cbind(newdat, pred_2[,2:3])
cst <- mean(c(0,coef(m_10)[3])) + mean(c(0,coef(m_10)[4])) # constant to average out sex and age effects
newdat[,4:8] <- newdat[,4:8] + cst

gg_degree <- ggplot(network_dat,aes(x=degree,y=feeding_freq)) +
  geom_point() +
  geom_ribbon(data=newdat,aes(ymin=P_lwr,ymax=P_upr),color=NA,alpha=0.08) + # prediction interval
  geom_ribbon(data=newdat,aes(ymin=lwr,ymax=upr),color=NA,alpha=0.2) + # confidence interval
  geom_line(data=newdat) +
  labs(x="Degree", y = "Feeder visits") +
  theme_gg

### strength
newdat <- data.frame(strength = seq(min(network_dat$strength,na.rm=TRUE),max(network_dat$strength,na.rm=TRUE),length.out = 10), age = "1Y", sex = "f")
pred <- predict(m_12,newdat,interval = "confidence")
newdat <- cbind(newdat, pred)
names(newdat)[4] <- "feeding_freq"
pred_2 <- predict(m_12,newdat,interval="prediction")
colnames(pred_2)[2:3] <- c("P_lwr","P_upr")
newdat <- cbind(newdat, pred_2[,2:3])
cst <- mean(c(0,coef(m_12)[3])) + mean(c(0,coef(m_12)[4])) # constant to average out sex and age effects
newdat[,4:8] <- newdat[,4:8] + cst

gg_strength <- ggplot(network_dat,aes(x=strength,y=feeding_freq)) +
  geom_point() +
  geom_ribbon(data=newdat,aes(ymin=P_lwr,ymax=P_upr),color=NA,alpha=0.08) + # prediction interval
  geom_ribbon(data=newdat,aes(ymin=lwr,ymax=upr),color=NA,alpha=0.2) + # confidence interval
  geom_line(data=newdat) +
  labs(x="Strength", y = "Feeder visits") +
  theme_gg

### put together and save the figure
gg_feed <- grid.arrange(gg_eigen,gg_betw,gg_degree,gg_strength)
ggsave("figures/fig_05.png",gg_feed)

# 4. fit the cort_induced ~ feeding frequency model
m_13 <- glm(cort_ind + 0.0001 ~ feeding_freq + barl_ind + sex + age, network_dat,family = Gamma(link="log"), subset = cort_ind < 10) # no detectable effect
m_14 <- lm(feeding_freq ~ cort_orig + barl_orig + sex +age, network_dat[-c(153, 258),])


scenario.dir<-file.path('c:','mv','sms','NS_63-10-OP','OP-constantF-6_stoc_rec')
  setwd(scenario.dir)

targetFs<-expand.grid(COD=seq(0.375,0.45,0.025),
                                                       WHG=seq(0.35,0.40,0.025),
                                                       HAD=seq(0.30,0.4,0.025),
                                                       POK=seq(0.40,0.40,0.025),
                                                       HER=seq(0.30,0.40,0.025),
                                                       SAN=seq(0.25,0.35,0.025),
                                                       NOR=seq(0.20,0.35,0.025),
                                                       SPR=seq(0.35,0.40,0.025),
                                                       PLE=seq(0.35,0.35,0.025),
                                                       SOL=seq(0.35,0.35,0.025))

  dim(targetFs)

  all.out<-'HCR_condensed.dat'

  res<-read.table(all.out,header=TRUE)
  b<-data.frame(iter=1:dim(targetFs)[[1]],targetFs)
  condensed<-merge(res,b)
  save(condensed, file =file.path(scenario.dir, "condensed.RData"))


scatterplot <- function (x,y,title,xlab,ylab) {
    stopifnot(is.vector(x))
    stopifnot(is.vector(y))
    stopifnot(length(x) == length(y))

    fit <- lm(y~x)
    base <- lm(y~1)
    p.value.lm <- anova(fit, base)[2, "Pr(>F)"]
    stats.desc <- paste(xlab, "\np[lm]= ",
                        format(p.value.lm,  digits = 3), sep = "")
    if (is.factor(x) || length(unique(x)) <= 20) {
        x <- as.factor(x)
        p <- (ggplot(data.frame(x=x,y=y), aes(x = x, y = y)) +
              geom_boxplot())
    }
    else {
        p <- (ggplot(data.frame(x=x,y=y), aes(x = x, y = y)) +
              geom_point() + geom_smooth(method = lm))
    }
    (p + ggtitle(title) + xlab(stats.desc) + ylab(ylab))
}


#' Iterator that chains multiple arguments together into a single iterator
#'
#' Generates an iterator that returns elements from the first argument until it
#' is exhausted. Then generates an iterator from the next argument and returns
#' elements from it. This process continues until all arguments are exhausted
#' Chaining is useful for treating consecutive sequences as a single sequence.
#'
#' @importFrom iterators iter nextElem
#' @export
#' @param ... multiple arguments to iterate through in sequence
#' @return iterator that iterates through each argument in sequence
#'
#' @examples
#' it <- ichain(1:3, 4:5, 6)
#' as.list(it)
#'
#' it2 <- ichain(1:3, levels(iris$Species))
#' as.list(it2)
ichain <- function(...) {
  iter_list <- lapply(list(...), iterators::iter)
  num_args <- length(iter_list)

  if (num_args == 0) {
    stop("At least one argument must be supplied.")
  }

  arg_i <- 1

  nextElem <- function() {
    # The repeated stop() call circumvents an error that appeared in a unit test
    # for itertools2::take().
    if (arg_i > num_args) {
      stop("StopIteration", call.=FALSE)
    }

    next_elem <- try(iterators::nextElem(iter_list[[arg_i]]), silent=TRUE)
    if (stop_iteration(next_elem)) {
      arg_i <<- arg_i + 1
      if (arg_i > num_args) {
        stop("StopIteration", call.=FALSE)
      } else {
        next_elem <- iterators::nextElem(iter_list[[arg_i]])
      }
    }
    next_elem
  }

  it <- list(nextElem=nextElem)
  class(it) <- c("abstractiter", "iter")
  it
}


 E04MTJ Example Program Results

++++++++++ Use the Primal-Dual algorithm ++++++++++

 ----------------------------------------------
  E04MT, Interior point method for LP problems
 ----------------------------------------------

 Original Problem Statistics

   Number of variables          7
   Number of constraints        7
   Free variables               0
   Number of nonzeros          41

 Presolved Problem Statistics

   Number of variables         13
   Number of constraints        7
   Free variables               0
   Number of nonzeros          47

 ------------------------------------------------------------------------------
  it|    pobj    |    dobj    |  optim  |  feas   |  compl  |   mu   | mcc | I
 ------------------------------------------------------------------------------
   0 -7.86591E-02  1.71637E-02  1.27E+00  1.06E+00  8.89E-02  1.5E-01
   1  5.74135E-03 -2.24369E-02  6.11E-16  1.75E-01  2.25E-02  2.8E-02   0
   2  1.96803E-02  1.37067E-02  5.06E-16  2.28E-02  2.91E-03  3.4E-03   0
   3  2.15232E-02  1.96162E-02  7.00E-15  9.24E-03  1.44E-03  1.7E-03   0
   4  2.30321E-02  2.28676E-02  1.15E-15  2.21E-03  2.97E-04  3.4E-04   0
   5  2.35658E-02  2.35803E-02  1.32E-15  1.02E-04  8.41E-06  9.6E-06   0
   6  2.35965E-02  2.35965E-02  1.64E-15  7.02E-08  6.35E-09  7.2E-09   0
Iteration 7
     monit() reports good approximate solution (tol = 1.20E-08):
   7  2.35965E-02  2.35965E-02  1.35E-15  3.52E-11  3.18E-12  3.6E-12   0
 ------------------------------------------------------------------------------
 Status: converged, an optimal solution found
 ------------------------------------------------------------------------------
 Final primal objective value         2.359648E-02
 Final dual objective value           2.359648E-02
 Absolute primal infeasibility        4.168797E-15
 Relative primal infeasibility        1.350467E-15
 Absolute dual infeasibility          5.084353E-11
 Relative dual infeasibility          3.518607E-11
 Absolute complementarity gap         2.685778E-11
 Relative complementarity gap         3.175366E-12
 Iterations                                      7

 Primal variables:
   idx   Lower bound        Value      Upper bound
     1  -1.00000E-02   -1.00000E-02    1.00000E-02
     2  -1.00000E-01   -1.00000E-01    1.50000E-01
     3  -1.00000E-02    3.00000E-02    3.00000E-02
     4  -4.00000E-02    2.00000E-02    2.00000E-02
     5  -1.00000E-01   -6.74853E-02    5.00000E-02
     6  -1.00000E-02   -2.28013E-03         inf
     7  -1.00000E-02   -2.34528E-04         inf

 Box bounds dual variables:
   idx   Lower bound        Value      Upper bound        Value
     1  -1.00000E-02    3.30098E-01    1.00000E-02    0.00000E+00
     2  -1.00000E-01    1.43844E-02    1.50000E-01    0.00000E+00
     3  -1.00000E-02    0.00000E+00    3.00000E-02    9.09967E-02
     4  -4.00000E-02    0.00000E+00    2.00000E-02    7.66124E-02
     5  -1.00000E-01    3.51391E-11    5.00000E-02    0.00000E+00
     6  -1.00000E-02    3.42902E-11         inf       0.00000E+00
     7  -1.00000E-02    8.61040E-12         inf       0.00000E+00

 Constraints dual variables:
   idx   Lower bound        Value      Upper bound        Value
     1  -1.30000E-01    0.00000E+00   -1.30000E-01    1.43111E+00
     2       -inf       0.00000E+00   -4.90000E-03    4.00339E-10
     3       -inf       0.00000E+00   -6.40000E-03    1.54305E-08
     4       -inf       0.00000E+00   -3.70000E-03    3.80136E-10
     5       -inf       0.00000E+00   -1.20000E-03    4.72629E-11
     6  -9.92000E-02    1.50098E+00         inf       0.00000E+00
     7  -3.00000E-03    1.51661E+00    2.00000E-03    0.00000E+00

++++++++++ Use the Self-Dual algorithm ++++++++++

 ----------------------------------------------
  E04MT, Interior point method for LP problems
 ----------------------------------------------

 Original Problem Statistics

   Number of variables          7
   Number of constraints        7
   Free variables               0
   Number of nonzeros          41

 Presolved Problem Statistics

   Number of variables         13
   Number of constraints        7
   Free variables               0
   Number of nonzeros          47

 ------------------------------------------------------------------------------
  it|    pobj    |    dobj    |  p.inf  |  d.inf  |  d.gap  |   tau  | mcc | I
 ------------------------------------------------------------------------------
   0 -6.39941E-01  4.94000E-02  1.07E+01  2.69E+00  5.54E+00  1.0E+00
   1 -8.56025E-02 -1.26938E-02  2.07E-01  2.07E-01  2.07E-01  1.7E+00   0
   2  4.09196E-03  1.24373E-02  4.00E-02  4.00E-02  4.00E-02  2.8E+00   0
   3  1.92404E-02  2.03658E-02  6.64E-03  6.64E-03  6.64E-03  3.2E+00   1
   4  1.99631E-02  2.07574E-02  3.23E-03  3.23E-03  3.23E-03  2.3E+00   1
   5  2.03834E-02  2.11141E-02  1.68E-03  1.68E-03  1.68E-03  1.4E+00   0
   6  2.22419E-02  2.25057E-02  5.73E-04  5.73E-04  5.73E-04  1.4E+00   1
   7  2.35051E-02  2.35294E-02  6.58E-05  6.58E-05  6.58E-05  1.4E+00   6
   8  2.35936E-02  2.35941E-02  1.19E-06  1.19E-06  1.19E-06  1.4E+00   0
Iteration 9
     monit() reports good approximate solution (tol = 1.20E-08):
   9  2.35965E-02  2.35965E-02  5.37E-10  5.37E-10  5.37E-10  1.4E+00   0
Iteration 10
     monit() reports good approximate solution (tol = 1.20E-08):
  10  2.35965E-02  2.35965E-02  2.68E-13  2.68E-13  2.68E-13  1.4E+00   0
 ------------------------------------------------------------------------------
 Status: converged, an optimal solution found
 ------------------------------------------------------------------------------
 Final primal objective value         2.359648E-02
 Final dual objective value           2.359648E-02
 Absolute primal infeasibility        2.853383E-12
 Relative primal infeasibility        2.677658E-13
 Absolute dual infeasibility          1.485749E-12
 Relative dual infeasibility          2.679654E-13
 Absolute complementarity gap         7.228861E-13
 Relative complementarity gap         2.683908E-13
 Iterations                                     10

 Primal variables:
   idx   Lower bound        Value      Upper bound
     1  -1.00000E-02   -1.00000E-02    1.00000E-02
     2  -1.00000E-01   -1.00000E-01    1.50000E-01
     3  -1.00000E-02    3.00000E-02    3.00000E-02
     4  -4.00000E-02    2.00000E-02    2.00000E-02
     5  -1.00000E-01   -6.74853E-02    5.00000E-02
     6  -1.00000E-02   -2.28013E-03         inf
     7  -1.00000E-02   -2.34528E-04         inf

 Box bounds dual variables:
   idx   Lower bound        Value      Upper bound        Value
     1  -1.00000E-02    3.30098E-01    1.00000E-02    0.00000E+00
     2  -1.00000E-01    1.43844E-02    1.50000E-01    0.00000E+00
     3  -1.00000E-02    0.00000E+00    3.00000E-02    9.09967E-02
     4  -4.00000E-02    0.00000E+00    2.00000E-02    7.66124E-02
     5  -1.00000E-01    3.66960E-12    5.00000E-02    0.00000E+00
     6  -1.00000E-02    2.47652E-11         inf       0.00000E+00
     7  -1.00000E-02    7.82645E-13         inf       0.00000E+00

 Constraints dual variables:
   idx   Lower bound        Value      Upper bound        Value
     1  -1.30000E-01    0.00000E+00   -1.30000E-01    1.43111E+00
     2       -inf       0.00000E+00   -4.90000E-03    1.07904E-10
     3       -inf       0.00000E+00   -6.40000E-03    1.14799E-09
     4       -inf       0.00000E+00   -3.70000E-03    4.09190E-12
     5       -inf       0.00000E+00   -1.20000E-03    1.52421E-12
     6  -9.92000E-02    1.50098E+00         inf       0.00000E+00
     7  -3.00000E-03    1.51661E+00    2.00000E-03    0.00000E+00


#
# This file is part of tsrsa.
#
# tsrsa is distributed in the hope that it will be useful,
# but WITHOUT ANY WARRANTY; without even the implied warranty of
# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.
#
# The data in tsrsa are not copyright by the maintainer of
# the package, and may not be freely available for redistribution.
# Check with your lawyer.

# Created: 2021.03.11
# Copyright: Steven E. Pav, 2017-2021
# Author: Steven E. Pav <steven@sharperat.io>
# Comments: Steven E. Pav

#' @title Daily Fama French 4 Factor Returns
#' @description The daily returns of the 4 Fama French Factors: Market, the cap factor SMB,
#' the growth factor HML, and the momentum factor UMD.
#' @format An \code{xts} object with 24,795 observations and 5 columns.
#' The data run from January, 1927 through December, 2020.
#' As in the upstream source, the data are given in \emph{percents}, meaning a
#' value of 1.00 corresponds to a 1\% movement.
#' Note also that returns presumably are \sQuote{simple} returns, not log
#' returns, though this is not clarified by the upstream source.
#' The columns are defined as follows:
#' \describe{
#'  \item{\code{Mkt}}{The Market daily return. Note that the risk free rate has been added back
#'  to the excess returns published by the upstream source.}
#'  \item{\code{SMB}}{The cap factor daily return.}
#'  \item{\code{HML}}{The growth factor daily return.}
#'  \item{\code{UMD}}{The momentum factor daily return.}
#'  \item{\code{RF}}{The risk-free rate, presumably as an daily rate, though note that no corrections have been
#'  made for weekend effects when adding the risk-free rate back to the market
#'  rate.}
#' }
#' @source Kenneth French data library.
#' See \url{http://mba.tuck.dartmouth.edu/pages/faculty/ken.french/data_library.html},
#' data description at \url{http://mba.tuck.dartmouth.edu/pages/faculty/ken.french/Data_Library/f-f_factors.html}.
#' @author Steven E. Pav \email{steven@@sharperat.io}
#' @examples
#' \dontrun{
#' data(dff4)
#' str(dff4)
#' }
"dff4"

#' @title Monthly Fama French 4 Factor Returns
#' @description The monthly returns of the 4 Fama French Factors: Market, the cap factor SMB,
#' the growth factor HML, and the momentum factor UMD.
#' @format An \code{xts} object with 1,128 observations and 5 columns.
#' The data run from January, 1927 through December, 2020.
#' As in the upstream source, the data are given in \emph{percents}, meaning a
#' value of 1.00 corresponds to a 1\% movement.
#' Note also that returns presumably are \sQuote{simple} returns, not log
#' returns, though this is not clarified by the upstream source.
#' The columns are defined as follows:
#' \describe{
#'  \item{\code{Mkt}}{The Market monthly return. Note that the risk free rate has been added back to the excess returns published by the upstream source.}
#'  \item{\code{SMB}}{The cap factor monthly return.}
#'  \item{\code{HML}}{The growth factor monthly return.}
#'  \item{\code{UMD}}{The momentum factor monthly return.}
#'  \item{\code{RF}}{The risk-free rate, presumably as a monthly rate. The average value is arround 0.28, corresponding to an annualized rate of around 3.3\%.}
#' }
#' @source Kenneth French data library.
#' See \url{http://mba.tuck.dartmouth.edu/pages/faculty/ken.french/data_library.html},
#' data description at \url{http://mba.tuck.dartmouth.edu/pages/faculty/ken.french/Data_Library/f-f_factors.html}.
#' @author Steven E. Pav \email{steven@@sharperat.io}
#' @examples
#' \dontrun{
#' data(mff4)
#' str(mff4)
#' }
"mff4"

#' @title Monthly Fama French 6 Factor Returns
#' @description The monthly returns of the 6 Fama French Factors:
#' Market,
#' the cap factor SMB,
#' the growth factor HML,
#' the momentum factor UMD,
#' the profitability factor RMW,
#' and the invesment factor CMA.
#'
#' @format An \code{xts} object with 690 observations and 7 columns.
#' The data run from July, 1963 through December, 2020.
#' As in the upstream source, the data are given in \emph{percents}, meaning a
#' value of 1.00 corresponds to a 1\% movement.
#' Note also that returns presumably are \sQuote{simple} returns, not log
#' returns, though this is not clarified by the upstream source.
#' The columns are defined as follows:
#' \describe{
#'  \item{\code{Mkt}}{The Market monthly return. Note that the risk free rate has been added back to the excess returns published by the upstream source.}
#'  \item{\code{SMB}}{The cap factor monthly return.}
#'  \item{\code{HML}}{The growth factor monthly return.}
#'  \item{\code{UMD}}{The momentum factor monthly return.}
#'  \item{\code{RMW}}{The profitability factor monthly return.}
#'  \item{\code{CMA}}{The investment factor monthly return.}
#'  \item{\code{RF}}{The risk-free rate, presumably as a monthly rate. The average value is arround 0.39, corresponding to an annualized rate of around 4.7\%.}
#' }
#' @source Kenneth French data library.
#' See \url{http://mba.tuck.dartmouth.edu/pages/faculty/ken.french/data_library.html},
#' and data description at \url{http://mba.tuck.dartmouth.edu/pages/faculty/ken.french/Data_Library/f-f_5_factors_2x3.html}.
#' @author Steven E. Pav \email{steven@@sharperat.io}
#' @examples
#' \dontrun{
#' data(mff6)
#' str(mff6)
#' }
"mff6"

#' @title Daily VIX Close
#' @description The daily closing value of the CBOE VIX index.
#' @format An \code{xts} object with 7,809 observations and 1 columns.
#' The data run from January, 1990 through December, 2020.
#' The columns are defined as follows:
#' \describe{
#'  \item{\code{VIX}}{The closing value of the VIX index.
#'  From January 2004 onward, the data are from the modern definition of the VIX index.
#'  The data from before 2004 are sourced from the back-computed data archive on CBOE.}
#' }
#' @source CBOE. See \url{http://www.cboe.com/products/vix-index-volatility/vix-options-and-futures/vix-index/vix-historical-data}.
#' @author Steven E. Pav \email{steven@@sharperat.io}
#' @examples
#' \dontrun{
#' data(dvix)
#' str(dvix)
#' }
"dvix"

#' @title Monthly Fama French 5 Industry Returns
#' @description The monthly returns of 5 industries: Consumer, Manufacturing, High Technology, Healthcare and Other.
#' @format An \code{xts} object with 1,128 observations and 5 columns.
#' The data run from January, 1927 through December, 2020.
#' As in the upstream source, the data are given in \emph{percents}, meaning a
#' value of 1.00 corresponds to a 1\% movement.
#' Note also that returns presumably are \sQuote{simple} returns, not log
#' returns, though this is not clarified by the upstream source.
#' The columns are defined as follows:
#' \describe{
#'  \item{\code{Consumer}}{The monthly returns of the Consumer industry, published as \dQuote{Cnsmr}.}
#'  \item{\code{Manufacturing}}{The monthly returns of the Manufacturing industry, published as \dQuote{Manuf}.}
#'  \item{\code{Technology}}{The monthly returns of the Technology industry, published as \dQuote{HiTec}.}
#'  \item{\code{Healthcare}}{The monthly returns of the Healthcare industry, published as \dQuote{Hlth}.}
#'  \item{\code{Other}}{The monthly returns of the Other industry, published as \dQuote{Other}.}
#' }
#' @source Kenneth French data library.
#' See \url{http://mba.tuck.dartmouth.edu/pages/faculty/ken.french/data_library.html},
#' data description at \url{http://mba.tuck.dartmouth.edu/pages/faculty/ken.french/Data_Library/det_5_ind_port.html}.
#' @author Steven E. Pav \email{steven@@sharperat.io}
#' @note These are not the \dQuote{ex dividend} returns series.
#' @examples
#' \dontrun{
#' data(mind5)
#' str(mind5)
#' }
"mind5"

#' @title Monthly Fama French 10 Industry Returns
#' @description The monthly returns of 10 industries: Nondurable goods, durable goods,
#' Manufacturing, Energy, High Technology, Telecom, Retail, Healthcare, Utilities and Other.
#' @format An \code{xts} object with 1,128 observations and 10 columns.
#' The data run from January, 1927 through December, 2020.
#' As in the upstream source, the data are given in \emph{percents}, meaning a
#' value of 1.00 corresponds to a 1\% movement.
#' Note also that returns presumably are \sQuote{simple} returns, not log
#' returns, though this is not clarified by the upstream source.
#' The columns are defined as follows:
#' \describe{
#'  \item{\code{NondurableGoods}}{The monthly returns of the nondurable goods industry, published as \dQuote{NoDur}.}
#'  \item{\code{DurableGoods}}{The monthly returns of the durable goods industry, published as \dQuote{Durbl}.}
#'  \item{\code{Manufacturing}}{The monthly returns of the Manufacturing industry, published as \dQuote{Manuf}.}
#'  \item{\code{Energy}}{The monthly returns of the Energy industry, published as \dQuote{Enrgy}.}
#'  \item{\code{Technology}}{The monthly returns of the Technology industry, published as \dQuote{HiTec}.}
#'  \item{\code{Telecom}}{The monthly returns of the Telecommunications industry, published as \dQuote{Telcm}.}
#'  \item{\code{Retail}}{The monthly returns of the Retail industry, published as \dQuote{Shops}.}
#'  \item{\code{Healthcare}}{The monthly returns of the Healthcare industry, published as \dQuote{Hlth}.}
#'  \item{\code{Utilities}}{The monthly returns of the Utilities industry, published as \dQuote{Utils}.}
#'  \item{\code{Other}}{The monthly returns of the Other industry, published as \dQuote{Other}.}
#' }
#' @source Kenneth French data library.
#' See \url{http://mba.tuck.dartmouth.edu/pages/faculty/ken.french/data_library.html},
#' data description at \url{http://mba.tuck.dartmouth.edu/pages/faculty/ken.french/Data_Library/det_10_ind_port.html}.
#' @author Steven E. Pav \email{steven@@sharperat.io}
#' @note These are not the \dQuote{ex dividend} returns series.
#' @examples
#' \dontrun{
#' data(mind10)
#' str(mind10)
#' }
"mind10"

#' @title Goyal Welch Equity Premium Data.
#' @description The yearly excess returns of the Market, aligned with a number
#' of lagging independent variables which have been posited to be predictive
#' of the excess returns.
#' @format An \code{xts} object with 215 observations and 23 columns.
#' The data are annual and span from 1802 through 2016.
#' As in the upstream source, the data are given in \emph{percents}, meaning a
#' value of 1.00 corresponds to a 1\% movement.
#' The columns are defined in the paper, but are roughly as follows:
#' \describe{
#'  \item{\code{cpi}}{The Consumer price index}
#'  \item{\code{gold}}{The spot price of gold}
#'  \item{\code{infl}}{Inflation as a percent?}
#'  \item{\code{tbill}}{The Treasury bill rate?}
#'  \item{\code{ltyld10}}{???}
#'  \item{\code{ltrate}}{???}
#'  \item{\code{callmoney}}{????}
#'  \item{\code{aaa}}{????}
#'  \item{\code{baa}}{????}
#'  \item{\code{corprate}}{????}
#'  \item{\code{corprate.i}}{????}
#'  \item{\code{sp500index}}{The closing value of the S&P 500 index.}
#'  \item{\code{sp500d12}}{????}
#'  \item{\code{sp500e12}}{????}
#'  \item{\code{vwm}}{????}
#'  \item{\code{vwx}}{????}
#'  \item{\code{svar}}{????}
#'  \item{\code{bkmk}}{????}
#'  \item{\code{ntis}}{????}
#'  \item{\code{eqis}}{????}
#'  \item{\code{csp}}{????}
#'  \item{\code{cay}}{????}
#'  \item{\code{ik}}{????}
#' }
#' @references
#' Welch, Ivo and Goyal, Amit. "A Comprehensive Look at The Empirical Performance of Equity Premium Prediction."
#' The Review of Financial Studies 21 , no. 4 (2007): 1455-1508. \url{https://doi.org/10.1093/rfs/hhm014}
#' @source Ivo Welch's data page, \url{http://www.ivo-welch.info/professional/goyal-welch/}.
#' @author Steven E. Pav \email{steven@@sharperat.io}
#' @examples
#' \dontrun{
#' data(gw)
#' str(gw)
#' }
"gw"

#for vim modeline: (do not edit)
# vim:fdm=marker:fmr=FOLDUP,UNFOLD:cms=#%s:syn=r:ft=r