library(tidyverse)
library(lubridate)
library(ggplot2)
library(scales)

# Read in data
nyt <- data.table::fread("https://raw.githubusercontent.com/nytimes/covid-19-data/master/us-states.csv")
# Removes some teritories
not_states <- c("Northern Mariana Islands", "Guam", "Virgin Islands", "Puerto Rico")
nyt <- nyt[which(!(nyt$state %in% not_states)),]

# Read in state code look up table - assuming 50 states + DC
codes <- read.csv("usa/data/states.csv", stringsAsFactors = FALSE)
names(codes) <- c("state", "code")
nyt <- left_join(nyt, codes, by = "state")

# Sort dates
nyt$date <- ymd(nyt$date)

# Work out cumulative cases by state
data <- nyt %>%
  group_by(code, date) %>%
  summarise(
    cumulative_cases = sum(cases),
    cumulative_deaths = sum(deaths)
  )

data_daily <- NULL
unique_codes <- unique(data$code)

less10deaths <- c()
less50deaths <- c()
# Working out daily deaths and cases
for (i in 1:length(unique_codes)){
  subset <- data[which(data$code == unique_codes[i]),]
  # Sort dates into ordere
  subset <- subset[order(subset$date),]
  # Fill in daily deaths
  daily_cases <- vector(length = length(subset$date))
  daily_deaths <- vector(length = length(subset$date))
  for (j in 1:length(subset$date)){
    if (j == 1){
      daily_cases[j] <- subset$cumulative_cases[j]
      daily_deaths[j] <- subset$cumulative_deaths[j]
    } else {
      daily_cases[j] <- subset$cumulative_cases[j] - subset$cumulative_cases[j-1]
      daily_deaths[j] <- subset$cumulative_deaths[j] - subset$cumulative_deaths[j-1]

      if (daily_cases[j] < 0){
        daily_cases[j] = 0
        print(sprintf("%s has a decrease in cumulative deaths on %s", unique_codes[i], subset$date[j]))
      }
      if (daily_deaths[j] < 0){
        daily_deaths[j] = 0
        print(sprintf("%s has a decrease in cumulative deaths on %s", unique_codes[i], subset$date[j]))
      }
    }
  }
  subset$daily_cases <- daily_cases
  subset$daily_deaths <- daily_deaths
  data_daily <- rbind(data_daily, subset)

  if (max(subset$cumulative_deaths) < 10){
    less10deaths <- c(less10deaths, unique_codes[i])
  }
  if (max(subset$cumulative_deaths) < 30){
    less50deaths <- c(less50deaths, unique_codes[i])
  }
}

print(sprintf("Last date in data is: %s", max(data_daily$date)))
print(sprintf("First date in data is: %s", min(data_daily$date)))
print("States with less than 10 cumulative deaths")
print(less10deaths)
print("States with less than 50 cumulative deaths")
print(less50deaths)

#-----------------------------------------------------------------------------
# Plotting code
p <- ggplot(data_daily) +
  geom_col(aes(x = date, y = cumulative_cases, group = code, fill = code)) +
  scale_x_date(date_breaks = "2 weeks", labels = date_format("%e %b")) +
  facet_wrap(~code) +
  theme_bw() +
  ylab("Cumulative cases") +
  xlab("") +
  theme(axis.text.x = element_text(angle = 45, hjust = 1),
        legend.position = "None")
ggsave("figures/state_cases.png", p, height = 10, width = 15)

p1 <- ggplot(data_daily) +
  geom_col(aes(x = date, y = daily_cases, group = code, fill = code)) +
  scale_x_date(date_breaks = "2 weeks", labels = date_format("%e %b")) +
  facet_wrap(~code) +
  theme_bw() +
  ylab("Daily number of cases") +
  xlab("") +
  theme(axis.text.x = element_text(angle = 45, hjust = 1),
        legend.position = "None")
ggsave("usa/figures/state_cases_daily.png", p1, height = 10, width = 15)

p2 <- ggplot(data_daily) +
  geom_col(aes(x = date, y = cumulative_deaths, group = code, fill = code)) +
  scale_x_date(date_breaks = "2 weeks", labels = date_format("%e %b")) +
  facet_wrap(~code) +
  ylab("Cumulative deaths") +
  xlab("") +
  theme_bw() +
  theme(axis.text.x = element_text(angle = 45, hjust = 1),
        legend.position = "None")
ggsave("usa/figures/state_deaths.png", p2, height = 10, width = 15)
print(p2)

p3 <- ggplot(data_daily) +
  geom_col(aes(x = date, y = daily_deaths, group = code, fill = code)) +
  scale_x_date(date_breaks = "2 weeks", labels = date_format("%e %b")) +
  facet_wrap(~code) +
  ylab("Daily number of deaths") +
  xlab("") +
  theme_bw() +
  theme(axis.text.x = element_text(angle = 45, hjust = 1),
        legend.position = "None")
ggsave("usa/figures/state_deaths_daily.png", p3, height = 10, width = 15)
print(p3)

#-----------------------------------------------------------------------------
# Padding with zeros

date_min <- ymd("2020-01-01")

all_data <- NULL

for (i in 1:length(unique_codes)){
  # Subset per state
  state_subset <- data_daily[which(data_daily$code == unique_codes[i]),]
  # Order by date
  state_subset <- state_subset[order(state_subset$date),]
  # Pad previous dates with zeros
  pad <- state_subset$date[1] - date_min
  pad_dates <- date_min + days(1:pad[[1]]-1)
  padded_data <- data.frame("code" = rep(unique_codes[i], pad),
                        "date" = pad_dates,
                        "cumulative_cases" = as.integer(rep(0, pad)),
                        "cumulative_deaths" = as.integer(rep(0, pad)),
                        "daily_cases" = as.integer(rep(0, pad)),
                        "daily_deaths" = as.integer(rep(0, pad)))

  state_data <- bind_rows(padded_data, state_subset)

  all_data <- bind_rows(all_data, state_data)
}

# Save RDS
saveRDS(all_data, file = "usa/data/nyt_death_data_padded.rds")


library(tidyverse)

a <- rnorm(200)
b <- rnorm(200)
dat <- data_frame(a,b) %>%
  mutate(sp = paste0("sp", rep(1:20, each = 10)))

write.csv(dat, "data.csv", row.names = F)


# under-sampling and bagging make prediction models

# setting
```{r}

########################## Data setting
### Setting
rm(list=ls(all=TRUE))

library(data.table)
library(dplyr)
library(ggplot2)
library(car)
library(psych)
library(pROC)
library(epitools)
library(tableone)
library(caret)
library(tictoc)
library(Boruta)

library(doParallel)
cl <- makePSOCKcluster(detectCores(all.tests = FALSE, logical = TRUE) - 1)
registerDoParallel(cl)

set.seed(1234)

######################### Input data
Data <- fread("Data_demo.csv", encoding = "UTF-8" )
Data$V1 <- NULL

colnames(Data)
dim(Data)

Data[, table(TrainTest), ]

Data_train <- Data[TrainTest == "Train", , ] #*eligible

Data_test <- Data[TrainTest == "Test", , ] #*eligible

Noise <- function(Var, Data){
		Var + rnorm(mean = 0, sd = sd(Var)/5, n = nrow(Data))
	}

RMSE <- function(Obs, Pred){
	Dif <- Pred - Obs
	RMSE <- round(sqrt(mean(Dif**2)), 2)
	return(RMSE)
}

MAE <- function(Obs, Pred){
	Dif <- Pred - Obs
	MAE <- Dif %>% abs() %>% mean()	%>% round(., 2)
	return(MAE)
}

MAPE <- function(Obs, Pred){
	Dif <- Pred - Obs
	MAPE <- mean(abs(Dif/Obs)*100) %>% round(., 2)
	return(MAPE)
}

```

#
```{r}

# CV methods
CV_method <- "cv"
CV_number <- 5
Repeated_number <- 1
Tune_number <- 1

# under-sampling parameters
Data_train_original <- data.frame(Data_train)

Parameter_grid <- expand.grid(
 	iii_Top_x_percentile = seq(0.90, 0.98, 0.01),
	iii_N_down = seq(100, 200, 100)
 	) %>% as.data.frame

Population_cut <- Data_train[AMPM == "PM" & Population100000 >= 5, ID, ] %>% unique()
Population_cut

```

# Under sampling setting
```{r}

# using variables
Var_use <- c(
	"Cluster_pred",
	"ID",
	"Date",

	"Population100000",
	"LogPopulation100000",
	"Mean_income_city_2015",
	"Green_area_percent",
	"Age_median_city",
	"Population_over_65_100000",
	"SexRatioF",

	"SeverityAll",

	"RainySeason",
	"DifDateRain",
	"holiday_flag",
	"Hour",
	"Month",

	"precip1Hour",
	"windSpeed_ms",
	"DownwardSolarRadiation_kwm2",
	"relativeHumidity",

	"temperature",
	"temperature_past1d_max_diff",
	"temperature_past1d_mean_diff",
	"temperature_past1d_min_diff"
)

# formula
Form_temp <- formula(
	SeverityAll ~

	Population100000 +
	Mean_income_city_2015 +
	Green_area_percent +
	Age_median_city +
	Population_over_65_100000 +
	SexRatioF +

	RainySeason +
	DifDateRain +
	holiday_flag +
	Hour +
	Month +

	precip1Hour +
	windSpeed_ms +
	DownwardSolarRadiation_kwm2 +
	relativeHumidity +

	temperature +
	temperature_past1d_max_diff +
	temperature_past1d_mean_diff +
	temperature_past1d_min_diff
)

# set seed
Size_n <- 36
Seeds_fix <- vector(mode = "list", length = CV_number * Repeated_number + 1)
for(i in 1:(CV_number * Repeated_number)) Seeds_fix[[i]] <- sample.int(n = 10000, size = Size_n )
Seeds_fix[[(CV_number * Repeated_number + 1)]] <- sample.int(10000, 1)
Seeds_fix

# construct rfeControl object
rfe_control = rfeControl(
	functions = caretFuncs,
	allowParallel = TRUE,
	method = CV_method,
    number = CV_number,
	returnResamp = "final",
	seeds = Seeds_fix
	)

# construct trainControl object for train method
fit_control = trainControl(
	allowParallel = TRUE,
	method = CV_method,
	number = CV_number,
	seeds = Seeds_fix
	)

```

# Under sampling
```{r}

tic(4)

# Under sampling
HogeRMSE <- c()
HogeMAPE <- c()

for(iii in 1:nrow(Parameter_grid)){

# read classifiers
Classifier <- readRDS(
	paste("Classifier",
		"_top_",
		Parameter_grid[iii, "iii_Top_x_percentile"],
		"_percent.rds",
		sep = ""
		)
	)

# predict classess
Data_train_cluster <- Data_train[ID %in% Population_cut, , ]
Data_train_cluster$Cluster_pred <- predict(Classifier, Data_train_cluster, pe = "raw")

Data_train_cluster_no <- Data_train[(ID %in% Population_cut) == FALSE, , ]
Data_train_cluster_no[, Cluster_pred := "99", ]

Data_train_cluster <- rbind(Data_train_cluster, Data_train_cluster_no)
Data_train_cluster <- Data_train_cluster[, Var_use, with = F]

# Under sampling b1-5
Temp_train <- c()
Temp_test <- c()

for(bbb in 1:10){
set.seed(bbb)

Data_train_cluster_auged <- sample_n(
		tbl = Data_train_cluster[Cluster_pred == "99", , ],
		size = Parameter_grid[iii, "iii_N_down"],
		replace = F
		)

Data_train_cluster_auged_bag <- rbind(Data_train_cluster_auged, Data_train_cluster[Cluster_pred != "99", , ])

	### Save data
	fwrite(
		Data_train_cluster_auged_bag,
		paste(
			"Data_train_top_",
			Parameter_grid[iii, "iii_Top_x_percentile"],
			"_percent_",
			Parameter_grid[iii, "iii_N_down"],
			"_under_",
			bbb,
			".csv", sep = "")
		)

# xgbTree
tic(6)
xgbTree_temp <- train(
	form = Form_temp,
	data = Data_train_cluster_auged_bag,
    method = "xgbTree",

	objective="reg:squarederror",
	trControl = fit_control,
	metric = "RMSE",
	preProcess = c("center", "scale"),
	tuneLength = 3
	#tuneGrid = tune_params
	)
summary(xgbTree_temp)
xgbTree_temp
toc(6)

# save models
saveRDS(xgbTree_temp,
	paste(
		"xgbTree_temp_model_",
		Parameter_grid[iii, "iii_Top_x_percentile"],
		"_percent_",
		Parameter_grid[iii, "iii_N_down"],
		"_under_",
		bbb,
		".rds", sep = ""
		)
	)

# Store
Temp_train <- cbind(Temp_train, predict(xgbTree_temp, Data_train, pe = "raw"))
Temp_test <- cbind(Temp_test, predict(xgbTree_temp, Data_test, pe = "raw"))

}

Temp_train <- data.table(Temp_train)
Temp_train[, Pred := rowMeans(Temp_train), ]
Temp_train[, Pred := ifelse(Pred < 0, 0, Pred), ]

Temp_test <- data.table(Temp_test)
Temp_test[, Pred := rowMeans(Temp_test), ]
Temp_test[, Pred := ifelse(Pred < 0, 0, Pred), ]

# get performance
Data_train[, Pred := Temp_train$Pred, ]
Data_test[, Pred := Temp_test$Pred, ]

RMSE_train <- RMSE(Obs = Data_train$SeverityAll, Pred = Data_train$Pred)

MAE_train <- MAE(Obs = Data_train$SeverityAll, Pred = Data_train$Pred)

Cor_train <- paste(
	cor.test(Data_train$SeverityAll, Data_train$Pred)$estimate %>% round(., 2),
	" (",
	cor.test(Data_train$SeverityAll, Data_train$Pred)$conf.int[1] %>% round(., 2),
	" to ",
	cor.test(Data_train$SeverityAll, Data_train$Pred)$conf.int[2] %>% round(., 2),
	")",
	sep = ""
	)

# get performance
RMSE_test <- RMSE(Obs = Data_test$SeverityAll, Pred = Data_test$Pred)

MAE_test <- MAE(Obs = Data_test$SeverityAll, Pred = Data_test$Pred)

Cor_test <- paste(
	cor.test(Data_test$SeverityAll, Data_test$Pred)$estimate %>% round(., 2),
	" (",
	cor.test(Data_test$SeverityAll, Data_test$Pred)$conf.int[1] %>% round(., 2),
	" to ",
	cor.test(Data_test$SeverityAll, Data_test$Pred)$conf.int[2] %>% round(., 2),
	")",
	sep = ""
	)

# Summarize
Performance <- c(
	paste(
	"xgbTree_temp_model_",
	Parameter_grid[iii, "iii_Top_x_percentile"],
	"_percent_",
	Parameter_grid[iii, "iii_N_down"],
	"_under", sep = ""
	),

	RMSE_train
	, RMSE_test

	, Cor_train
	, Cor_test
	)

HogeRMSE <- rbind(HogeRMSE, Performance)

# Organized dataset
Data_train_MAPE <- Data_train %>%
	group_by(Date) %>%
	summarise(
		Obs = sum(SeverityAll),
		Pred = sum(Pred)
		) %>% data.table()

Data_train_MAPE[, Year := year(Date), ]

Data_train_MAPE[, Spike :=
	ifelse(Year == 2015 & Obs >= Data_train_MAPE[Year == 2015, quantile(Obs, 0.8), ], 1,
	ifelse(Year == 2016 & Obs >= Data_train_MAPE[Year == 2016, quantile(Obs, 0.8), ], 1,
	ifelse(Year == 2017 & Obs >= Data_train_MAPE[Year == 2017, quantile(Obs, 0.8), ], 1, 0)))
	, ]
Data_train_MAPE[, table(Spike), ]
Data_train_MAPE[, table(Spike), ] / nrow(Data_train_MAPE)

# get performance
MAPE_train <- MAPE(
	Obs = Data_train_MAPE[Spike == 1, Obs, ],
	Pred = Data_train_MAPE[Spike == 1, Pred, ]
	)

PE_train <- Data_train_MAPE[Spike == 1, round( (abs(sum(Pred) - sum(Obs)) / sum(Obs) ) * 100, 2), ]

# Organized dataset
Data_test_MAPE <- Data_test %>%
	group_by(Date) %>%
	summarise(
		Obs = sum(SeverityAll),
		Pred = sum(Pred)
		) %>% data.table()

Data_test_MAPE[, Year := year(Date), ]

Data_test_MAPE[, Spike :=
	ifelse(Year == 2018 & Obs >= Data_test_MAPE[Year == 2018, quantile(Obs, 0.8), ], 1, 0)
	, ]
Data_test_MAPE[, table(Spike), ]
Data_test_MAPE[, table(Spike), ] / nrow(Data_test_MAPE)

# get performance
MAPE_test <- MAPE(
	Obs = Data_test_MAPE[Spike == 1, Obs, ],
	Pred = Data_test_MAPE[Spike == 1, Pred, ]
	)

PE_est <- Data_test_MAPE[Spike == 1, round( (abs(sum(Pred) - sum(Obs)) / sum(Obs) ) * 100, 2), ]

# Summarize
Performance <- c(
	paste(
	"xgbTree_temp_model_",
	Parameter_grid[iii, "iii_Top_x_percentile"],
	"_percent_",
	Parameter_grid[iii, "iii_N_down"],
	"_under", sep = ""
	),

	MAPE_train
	, MAPE_test

	, PE_train
	, PE_est
	)

HogeMAPE <- rbind(HogeMAPE, Performance)

# get predicted values
Data_train$Predicted <- Data_train$Pred
Data_train$Obserbved <- Data_train$SeverityAll

# get predicted values
Data_test$Predicted <- Data_test$Pred
Data_test$Obserbved <- Data_test$SeverityAll

## Make figures
ggplot(data = Data_train, aes(x = Predicted, y = Obserbved)) +
	geom_point() +
	geom_smooth(method = lm) +
	scale_x_continuous(limits = c(0, 100), breaks = seq(0, 100, 10)) +
	scale_y_continuous(limits = c(0, 100), breaks = seq(0, 100, 10)) +
	xlab("") +
	ylab("") +
	theme_classic()

ggsave(
	paste(
		"Out_plot_",
		"xgbTree_temp_model_",
		Parameter_grid[iii, "iii_Top_x_percentile"],
		"_percent_",
		Parameter_grid[iii, "iii_N_down"],
		"_under",
		"_train.png", sep = ""),
		width = 4.2, height = 3.2
		) #*action

### Make figures taest
ggplot(data = Data_test, aes(x = Predicted, y = Obserbved)) +
	geom_point() +
	geom_smooth(method = lm) +
	scale_x_continuous(limits = c(0, 100), breaks = seq(0, 100, 10)) +
	scale_y_continuous(limits = c(0, 100), breaks = seq(0, 100, 10)) +
	xlab("") +
	ylab("") +
	theme_classic()

ggsave(
	paste(
		"Out_plot_",
		"xgbTree_temp_model_",
		Parameter_grid[iii, "iii_Top_x_percentile"],
		"_percent_",
		Parameter_grid[iii, "iii_N_down"],
		"_under",
		"_test.png", sep = ""),
		width = 4.2, height = 3.2
		) #*action

### Make Fig train
DataSum_train <- Data_train %>%
	group_by(Date) %>%
	summarise(
		Obserbved = sum(Obserbved),
		Predicted = sum(Predicted)
		) %>%
	data.table()

DataSum_test <- Data_test %>%
	group_by(Date) %>%
	summarise(
		Obserbved = sum(Obserbved),
		Predicted = sum(Predicted)
		) %>%
	data.table()

DataSum <- rbind(DataSum_train, DataSum_test)

DataSum[, Date:=as.Date(Date), ]
DataSum[, YearUse:=year(Date), ]
DataSum <- DataSum[order(Date), , ]
DataSum[, Day:=1:length(Obserbved), by = YearUse]

DataSum[Date == as.Date("2015-06-01"), , ]
DataSum[Date == as.Date("2015-07-01"), , ]
DataSum[Date == as.Date("2015-08-01"), , ]
DataSum[Date == as.Date("2015-09-01"), , ]

ggplot(data = DataSum, aes(x = Day), group=factor(YearUse)) +
	geom_line(aes(y = Obserbved, x=Day), colour = "Black", size = 0.4) +
	geom_line(aes(y = Predicted, x=Day), colour = "Red", size = 0.4) +
	xlab("") +
	ylab("") +

	scale_y_continuous(
		limits = c(0, 450),
		breaks = seq(0, 450, 50)
		) +

	scale_x_continuous(
		label = c("Jun.", "Jul.", "Aug.", "Sep."),
		breaks = c(1, 31, 62, 93)
		) +
	theme(axis.text.x = element_text(angle = 90, hjust = 1)) +
	facet_grid(~YearUse) +
	theme_classic()

ggsave(
	paste(
		"Out_time_24_",
		"xgbTree_temp_model_",
		Parameter_grid[iii, "iii_Top_x_percentile"],
		"_percent_",
		Parameter_grid[iii, "iii_N_down"],
		"_under",
		".png", sep = ""),
		width = 6.7 * 1.5, height = 3.5 * 0.66
		) #*action

}

fwrite(HogeRMSE, "Out_RMSE_under.csv")
fwrite(HogeMAPE, "Out_MAPE_under.csv")

toc(4)

toc(1)

```


# comparison with MSVPA
 nox<-2; noy<-3;
sms<-Read.summary.data()

if (F) {
  file<-file.path(root,'data_Northsea','summary.out')

  MSVPA.no<-c('COD','WHG','HAD','POK','HER','SAN','NOP')
  MSVPA.sp<-c('Cod','Whiting','Haddock','Saithe','Herring','Sandeel','Nor. pout')
  MSVPA.prey<-c('Cod','Whiting','Haddock','Herring','Sandeel','Nor. pout')
}
if (T) {
  file<-file.path(root,'data_baltic','Compar01.out')

  MSVPA.no<-c('COD','HER','SPR')
  MSVPA.sp<-c('Cod','Herring','Sprat')
  MSVPA.prey<-MSVPA.sp
}
s<-read.table(file,header=TRUE)

msvpa<-data.frame(MSVPA.species=s$species,  #Species.n=match(s$species,MSVPA.no),
          Species=MSVPA.sp[match(s$species,MSVPA.no)],Age=s$age,Year=s$year,
           MSVPA.M2=s$M2,Quarter=s$quarter,MSVPA.SSB=s$SSB)
unique(msvpa$Species)

b<-merge(sms,msvpa,by=c('Year','Quarter','Age','Species'))
unique(b$Species)

M2<-tapply(b$M2,list(b$Year,b$Age,b$Species),sum,na.rm=T)

msvpa.M2<-tapply(b$MSVPA.M2,list(b$Year,b$Age,b$Species),sum,na.rm=T)

##########################  M2 plot (sum af quarterly M (wrong!!)  #############

#clear graphical windows
 cleanup()

dev<-"print"
dev<-"screen"
nox<-2; noy<-3;
noxy<-nox*noy
par(ask=TRUE)

cleanup()

#by species
year<-as.numeric(dimnames(M2)[[1]])
for (sp in MSVPA.prey) {

  newplot(dev,nox,noy);
  par(mar=c(3,5,3,2))
  i<-0
  for (age in (fa:5)) {
    a<-age+1
    if (i==noxy) {newplot(dev,nox,noy); i<-0 }
    max.M2<-max(M2[,a,sp],msvpa.M2[,a,sp])
   print(max.M2)
    if (!is.na(max.M2)) if (max.M2>0.001) {
      plot(year,M2[,a,sp],xlab=" ",ylab="M2",main=paste(sp,' age:',age),type='b', ylim=c(0,max.M2),col=1 )
      lines(year,msvpa.M2[,a,sp],col=4)
      i<-i+1
    }
    a<-age+1
  }
}

#######################################################
# M2 plot for report (on file if dev="wmf")

#Reformat output
dev<-"print"
dev<-"screen"
#dev<-"wmf"

nox<-4; noy<-3;
noxy<-nox*noy
par(ask=TRUE)

cleanup()
#by species
year<-as.numeric(dimnames(M2)[[1]])
  i<-0
  pic<-1
  newplot(dev,nox,noy,filename="annual_M2_1")
  par(mar=c(3,5,3,2))

  for (sp in (1:nsp)) {
  for (age in (fa:3)) {
    a<-age+1
    if (i==noxy) {pic<-pic+1; newplot(dev,nox,noy,filename=paste("annual_M2_",pic,sep="")); i<-0 }
    max.M2<-max(M2[,a,sp],msvpa.M2[,a,sp])
    if (!is.na(max.M2)) if (max.M2>0.001) {
      plot(year,M2[,a,sp],xlab=" ",ylab="M2",main=paste(name[sp+1]," age:",age),type='b', ylim=c(0,max.M2),col=1 )
      lines(year,msvpa.M2[,a,sp],col=4)
      i<-i+1
    }
  }
}

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

nox<-1; noy<-1;
noxy<-nox*noy
i<-0
newplot(dev,nox,noy)
#by species
year<-as.numeric(dimnames(M2)[[1]])
for (sp in (1:nsp)) {
  if (i==noxy) {newplot(dev,nox,noy); i<-0 }
  max.M2<-max(M2[,,sp],na.rm=T)
  if (!is.na(max.M2)) if (max.M2>0.001) {
    plot(year,M2[,fa+1,sp],xlab=" ",ylab="M2",main=name[sp+1],type='b', ylim=c(0,max.M2),pch=as.character(0) )
    i<-i+1
    for (age in ((fa+1):8)) {
      a<-age+1
      max.M2<-max(M2[,a,sp])
      if (!is.na(max.M2)) if (max.M2>0.001) lines(year,M2[,a,sp],type='b',pch=as.character(age),col=a)
    }
  }
}

############################################################
##SSB

c<-subset(b,Quarter==1,drop=T)

SSB<-tapply(c$SSB,list(c$Year,c$Species.n),sum,na.rm=T)/1000

msvpa.SSB<-tapply(c$MSVPA.SSB,list(c$Year,c$Species.n),sum,na.rm=T)/1000000

dev<-"print"
dev<-"screen"
#dev<-"wmf"

nox<-2; noy<-2
noxy<-nox*noy
par(ask=TRUE)

cleanup()

#by species
 newplot(dev,nox,noy,filename="SSB_MSVPA_SMS");
 i<-0
year<-as.numeric(dimnames(SSB)[[1]])
for (sp in (1:nsp)) {
    if (i==noxy) {newplot(dev,nox,noy,filename="SSB_MSVPA_SMS"); i<-0 }
    max.SSB<-max(SSB[,sp],msvpa.SSB[,sp])
      plot(year,SSB[,sp],xlab=" ",ylab="SSB (1000t)",main=name[sp+1],type='b', ylim=c(0,max.SSB),col=1 )
      lines(year,msvpa.SSB[,sp],col=4)
      i<-i+1
}
if (dev!="screen") cleanup()


"This script generates the data files required for setting up
an Instrument (for CDI-IRT administrations) on e-Babylab.
Change the definitions for 'lang', 'type', and 'resp' as needed."

pacs <- c("wordbankr","plyr","dplyr","tidyr","stats4","openxlsx","mirt","mirtCAT",
          "sweep","purrr","tidyverse","tictoc","parallel","doParallel", "readr") #"tictoc","parallel","doParallel",
invisible(lapply(pacs,library,character.only=TRUE))

########## Configure settings here
lang <- "German" # use get_instruments() to see what languages and forms are available on wordbank
type <- "WS" # "WS" or "WG"
resp <- "production" # "comprehension" or "production"

d_poly <- 3
poly_mode <- "Flexi" #"Fixed" #"Fixed" # or
criteria <- "incl.anyFinite" # or "excl.Inf" — for evaluation of log = -inf
gen_list <- c("Female", "Male")

########## Functions
# Get data from word bank
prep_data <- function(){
  admin_ws <<- get_administration_data(lang, type)
  if(lang == "English (American)"){
    admin_ws <<- admin_ws #%>% filter(norming=="TRUE")
  }
  data_ws <<- get_instrument_data(lang, type)
  if(lang == "English (American)"){
    data_ws <<- data_ws %>% filter(data_id %in% admin_ws$data_id)
  }
  items_ws <<- get_item_data(lang, type)

  # reduce datasets
  items_ws <<- subset(items_ws, type=="word")
  num_words <<- nrow(items_ws)
  data_ws <<- data_ws %>% filter(num_item_id %in% items_ws$num_item_id)
  if (type == "WS" | (type == "WG" & resp == "production")) {
    data_ws <- data_ws %>%
      mutate(value = ifelse(value %in% c("produces", "yes", "sometimes", "often"),
                            1,
                            0))
  } else if (type == "WG" & resp == "comprehension") { # WG
    data_ws <- data_ws %>%
      mutate(value = ifelse(value %in% c("no", "never", "not yet", "") | is.na(value),
                            0,
                            1))
  }
  data_ws$value <<- as.numeric(data_ws$value)
}

# Prepare admin_data_all for simulation (by merging admin_ws and data_ws)
data_in <- function(){
  if (type == "WS") {
    inner_join(data_ws, select(admin_ws, age, data_id, sex, production), by="data_id")
  } else if (type == "WG") {
    inner_join(data_ws, select(admin_ws, age, data_id, sex, all_of(resp)), by="data_id")
  }
}

# Get percentages for each word in each age
perc_word <- function(){
  temp <- select(admin_data_all,num_item_id,value,age)
  word_dist <<- temp %>% dplyr::group_by(age,num_item_id) %>% dplyr::summarise(perc = mean(value))
}

# Order percentage word
get_order <- function(df){order(df$perc)}

# Model for MLE
LL <- function(m, sd) {
  R = dnorm(scores, m, sd)
  -sum(log(R))
}

# Apply mle model
mle_model <- function(dfdata,...){
  # i <<- i + 1 # troubleshooting
  # print(i) # troubleshooting
  if (type == "WS") { # check CDI type
    scores <<- dfdata$production
    scores <<- scores[scores != 0] # remove zeros
    check <<- scores[scores != 0]
    if (length(check) > item_threshold) {
      mle(LL, start = list(m = mean(scores), sd = sd(scores)),
          method = "L-BFGS-B")
    } else{
      NaN
    }
  } else if (type == "WG") { # check CDI type
    if (resp == "comprehension"){
      scores <<- dfdata$comprehension
      scores <<- scores[scores != 0] # remove zeros
      check <<- scores[scores != 0]
    } else if (resp == "production"){
      scores <<- dfdata$production
      scores <<- scores[scores != 0] # remove zeros
      check <<- scores[scores != 0]
    }
    if (length(check) > item_threshold) {
      mle(LL, start = list(m = mean(scores), sd = sd(scores)))#,
      # method = "L-BFGS-B")
    } else{
      NaN
    }
  }
}

# Fill in "missing" words and Reorder according to word_purr
fill_in_and_sort <- function(dfage,df){
  # ex <- data.frame(1:num_words)
  sorted <<- word_dist$num_item_id %>% unique() %>% data.frame()
  colnames(sorted) <- "num_item_id"
  full_join(sorted, df, by = "num_item_id")
}

# Configuration for polynomial
poly_cfg <- function(mode = "Flexi"){

  age <<- admin_data_all$age %>% unique %>% sort
  ageN <- count(admin_data_all,age)

  # Measures size
  if (median(as.matrix(ageN[,2])) > 200){
    size <- "large"
  } else if (median(as.matrix(ageN[,2])) <= 200 & median(as.matrix(ageN[,2])) > 100){
    size <- "medium"
  } else if (median(as.matrix(ageN[,2])) <= 100 & median(as.matrix(ageN[,2])) > 50){
    size <- "small"
  } else if (median(as.matrix(ageN[,2])) <= 50) {
    size <- "tiny"
  }
  print(size)

  if (mode == "Fixed"){
    matrix(3, length(age), 1, dimnames = list(c(age), c("poly")))

  } else if (mode == "Flexi"){
    if(type == "WS"){
      # Flexi Poly
      df_mad <- admin_data_all %>% ungroup() %>% select(age,production)
      df_mad <- aggregate(. ~ age, df_mad, function(x) c(median = median(x), mad = mad(x)))
      temp_df <- cbind(df_mad[,1],df_mad$production[,2]) %>%
        data.frame %>%
        mutate(poly = ifelse(X2 < 100, 1, 3))
      # Extract poly num only
      as.matrix(temp_df[,3])
    } else if (type == "WG" & resp == "comprehension"){
      # Flexi Poly
      df_mad <- admin_data_all %>% select(age,all_of(resp))
      df_mad <- aggregate(. ~ age, df_mad, function(x) c(median = median(x), mad = mad(x)))
      temp_df <- cbind(df_mad[,1],
                       (df_mad %>% select(all_of(resp)) %>% data.frame)[,1][,2]) %>% # dynamic columns
        data.frame %>%
        mutate(poly = ifelse(X2 < 100, 1, 3))
      # Extract poly num only
      as.matrix(temp_df[,3])

    } else if (type == "WG" & resp == "production"){

      # Flexi Poly Original
      df_mad <- admin_data_all %>% select(age,all_of(resp))
      df_mad <- aggregate(. ~ age, df_mad, function(x) c(median = median(x), mad = mad(x)))
      temp_df <- cbind(df_mad[,1],
                       (df_mad %>% select(all_of(resp)) %>% data.frame)[,1][,2]) %>% # dynamic columns
        data.frame %>%
        mutate(poly = ifelse(X2 < 100, 1, 3))
      # Extract poly num only
      as.matrix(temp_df[,3])
    }
  }
}

# Fit degree of polynomial
poly_fit_mean <- function(dfage,df,...){
  d_poly <<- idpoly[which(age == dfage)]
  if (any(is.finite(df$mean))) {
    model <<- lm(df$mean~poly(c(1:num_words), d_poly, raw = TRUE))
    pmax(20, predict(model, newdata=data.frame(c(1:num_words))))
  } else {
    NaN
  }
}

poly_fit_sd <- function(dfage,df,...){
  d_poly <<- idpoly[which(age == dfage)]
  if (any(is.finite(df$sd))) {
    model <<- lm(df$sd~poly(c(1:num_words), d_poly, raw = TRUE))
    pmax(20, predict(model, newdata=data.frame(c(1:num_words))))
  } else {
    NaN
  }
}

# log PDF of normal distribution
log_pdf <- function(df){
  log(dnorm(c(0,1:num_words),df$lm_mean,df$lm_sd), base = exp(1))
}

# Filter log dnorm pdf
filter_log_pdf <- function(df, criteria){
  if(criteria == "excl.Inf"){

    df$filt <- is.finite(as.numeric(map(df$log,sum)))
  } else if (criteria == "incl.anyFinite"){

    df$filt <- as.numeric(map(df$log,ls.is.finite))
  } else {
    cat("Input error.")
  }
}

# Filter log dnorm pdf by Rows
ls.is.finite <- function(df){
  ifelse(any(is.finite(unlist(df)))==TRUE,TRUE,FALSE)}

# sum of log (basis)
sum_log <- function(df){
  list(reduce(df,`+`) + 1)
}

# max basis
max_basis <- function(df){
  as.numeric(which(unlist(df) == max(unlist(df), na.rm = T)))
}

# max basis
max_basis_test <- function(df, value){
  if (value == 0){
    as.numeric(which(unlist(df) == max(unlist(df), na.rm = T)))
  } else if (value == 1){
    as.numeric(which(unlist(df) == max(unlist(df), na.rm = T))) + 1
  }
}

# calculate slope
get_slope <- function(df){
  diff(df)/num_words
}

# Configuration for CAT simulations
cat_cfg <- function(mode = "NoPreCAT") {
  if (mode == "NoPreCAT"){
    CAT_mode <<- list("NoPreCAT", list())
  } else if (mode == "PreCATFlex"){
    CAT_mode <<- list("PreCATFlex", list(min_items = 0, max_items = 10,
                                         criteria = "MI", method = "WLE",
                                         response_variance = TRUE))
  } else if (mode == "PreCAT") {
    CAT_mode <<- list("PreCAT", list(min_items = 10, max_items = 10,
                                     criteria = "MI", method = "WLE"))
  }
}

remove_dataID <- function(df){df %>% select(-c(data_id))}

filter_response <- function(df){Filter(var,df)}

# Fit data to IRT
fit_item_mirt <- function(df){mirt(df, 1, itemtype = "2PL", method = "EM", SE=TRUE)}

########## Code

# Prepare data
prep_data() # Extract data from wordbank
admin_ws <- admin_ws # %>% filter(!(age < 11 & production > 100)) # extra filter for extreme outliers

admin_data_all <- data_in() #  merging admin_ws and data_ws

word_dist <- perc_word() # percentage for each word in each age
word_dist$perc <- round(word_dist$perc, digits=2) # rounding

default_test <- c(num_words, 400, 200, 100, 50, 25, 10, 5)
test <- c(num_words, default_test[default_test < num_words])

# Convert admin_data_all and word_dist for purr and furr
data_purr <- admin_data_all %>% group_by(sex, value, age, num_item_id) %>%
  nest() # main set

word_purr <- word_dist %>% select(-c("num_item_id")) %>% group_by(age) %>% nest() %>%
  mutate(data = map(data, get_order))

# Modeling
#Mod# Maximum likelihood estimation
item_threshold <- 5 # min amount of data point needed to fit mle

mle_purr <- data_purr
mle_purr$model <- pmap(list(data_purr$data), mle_model)

mle_purr$mean <- foreach(i = 1:nrow(mle_purr), .combine = rbind) %do% {
  try(coef(mle_purr$model[[i]])[1], silent=TRUE) %>% as.numeric()
}
mle_purr$sd  <- foreach(i = 1:nrow(mle_purr), .combine = rbind) %do% {
  try(coef(mle_purr$model[[i]])[2], silent=TRUE) %>% as.numeric()
}

mle_purr <- mle_purr %>% select(-c("model"))
mle_purr$mean[which(is.na(mle_purr$mean))] <- NaN
mle_purr$sd[which(is.na(mle_purr$sd))] <- NaN

#Mod# poly 3 or flexi
prep_purr <- mle_purr %>% select(-c("data")) %>%
  group_by(sex,value,age) %>% nest()

prep_purr$data2 <- pmap(list(prep_purr$age,prep_purr$data), fill_in_and_sort)
prep_purr <- prep_purr %>%
  select(-c("data"))

idpoly <- poly_cfg(mode = poly_mode) # polynomial flexible, f(MAD)

poly_purr <- prep_purr
poly_purr$lm_mean <- pmap(list(prep_purr$age, prep_purr$data2), poly_fit_mean)
poly_purr$lm_sd <- pmap(list(prep_purr$age, prep_purr$data2), poly_fit_sd)
poly_purr <- poly_purr %>% unnest %>% nest(-c(sex,value,age,num_item_id))

#Mod# log PDF of normal distribution
log_pdf_purr_raw <- poly_purr
log_pdf_purr_raw$log  <- map(poly_purr$data, log_pdf)
log_pdf_purr_raw <- log_pdf_purr_raw %>%
  select(-data)

# Filter log dnorm pdf
log_pdf_purr <- log_pdf_purr_raw
log_pdf_purr$filt <- filter_log_pdf(log_pdf_purr_raw, criteria) # "excl.Inf" or
log_pdf_purr <- log_pdf_purr %>% filter(filt == 1)

#Mod# norms: basis for all items
all_basis <- log_pdf_purr %>% group_by(sex,value,age) %>% summarise(data = sum_log(log))

#Mod# Get Bmin (np_param) & slope for real-data simulation
param <- all_basis %>% group_by(sex,value,age) %>% summarise(B = max_basis(data))
np_param <- param %>% subset(value == 0)
slope <- param %>% group_by(sex,age) %>% summarise(slope = get_slope(B))

for (gen in c("Female", "Male")) {

  slope2 = slope %>% ungroup() %>% filter(sex == gen) %>%
    select(age, slope) %>% spread(age, slope)
  Bmin = np_param %>% ungroup() %>% filter(sex == gen) %>%
    select(age, B) %>% spread(age, B)
  poly_unnest <- poly_purr %>% unnest()

  lm_p_mean = poly_unnest %>% ungroup() %>% filter(sex == gen & value == 1) %>%
    select(age, lm_mean, num_item_id) %>% spread(age, lm_mean) %>%
    mutate(word_id = num_item_id) %>%
    select(-num_item_id) %>% select(word_id, colnames(.[,1:(ncol(.)-1)]))
  lm_p_sd = poly_unnest %>% ungroup() %>% filter(sex == gen & value == 1) %>%
    select(age, lm_sd, num_item_id) %>% spread(age, lm_sd) %>%
    mutate(word_id = num_item_id) %>%
    select(-num_item_id) %>% select(word_id, colnames(.[,1:(ncol(.)-1)]))
  lm_np_mean = poly_unnest %>% ungroup() %>% filter(sex == gen & value == 0) %>%
    select(age, lm_mean, num_item_id) %>% spread(age, lm_mean) %>%
    mutate(word_id = num_item_id) %>%
    select(-num_item_id) %>% select(word_id, colnames(.[,1:(ncol(.)-1)]))
  lm_np_sd = poly_unnest %>% ungroup() %>% filter(sex == gen & value == 0) %>%
    select(age, lm_sd, num_item_id) %>% spread(age, lm_sd) %>%
    mutate(word_id = num_item_id) %>%
    select(-num_item_id) %>% select(word_id, colnames(.[,1:(ncol(.)-1)]))

  if (type == "WS") {
    fname1 <- paste("p_m", gen, lang, type, sep="-")
    fname1 <- paste(fname1, "csv", sep = ".")
    fname2 <- paste("p_sd", gen, lang, type, sep="-")
    fname2 <- paste(fname2, "csv", sep = ".")
    fname3 <- paste("np_m", gen, lang, type, sep="-")
    fname3 <- paste(fname3, "csv", sep = ".")
    fname4 <- paste("np_sd", gen, lang, type, sep="-")
    fname4 <- paste(fname4, "csv", sep = ".")
    fname5 <- paste("BMin", gen, lang, type, sep="-")
    fname5 <- paste(fname5, "csv", sep = ".")
    fname6 <- paste("Slope", gen, lang, type, sep="-")
    fname6 <- paste(fname6, "csv", sep = ".")
  } else if (type == "WG") {
    fname1 <- paste("p_m", gen, lang, type, resp, sep="-")
    fname1 <- paste(fname1, "csv", sep = ".")
    fname2 <- paste("p_sd", gen, lang, type, resp, sep="-")
    fname2 <- paste(fname2, "csv", sep = ".")
    fname3 <- paste("np_m", gen, lang, type, resp, sep="-")
    fname3 <- paste(fname3, "csv", sep = ".")
    fname4 <- paste("np_sd", gen, lang, type, resp, sep="-")
    fname4 <- paste(fname4, "csv", sep = ".")
    fname5 <- paste("BMin", gen, lang, type, resp, sep="-")
    fname5 <- paste(fname5, "csv", sep = ".")
    fname6 <- paste("Slope", gen, lang, type, resp, sep="-")
    fname6 <- paste(fname6, "csv", sep = ".")
  }

  readr::write_csv(lm_p_mean, fname1)
  readr::write_csv(lm_p_sd, fname2)
  readr::write_csv(lm_np_mean, fname3)
  readr::write_csv(lm_np_sd, fname4)
  readr::write_csv(Bmin, fname5)
  readr::write_csv(slope2, fname6)

}

fname7 <- paste("word_list", lang, type, resp, sep="-")
fname7 <- paste(fname7, "csv", sep = ".")
wordonly <- items_ws %>% mutate(word = definition, word_id = num_item_id) %>%
  select(word_id, word)
readr::write_csv(wordonly, fname7)

#### Item Response Theory, IRT
cat_cfg(mode = "NoPreCAT") # NoPreCAT

num_words <- max(admin_data_all$num_item_id)
test <- c(num_words, 400, 200, 100, 50, 25, 10, 5)

# Fit IRT (overall)
data_irt <- admin_data_all %>% #filter(between(age, 16, 30)) %>%
  select(value,num_item_id,data_id) %>%
  spread(num_item_id,value) %>% select(-data_id)
data_irt <- Filter(var,data_irt)
items <- mirt(data_irt, 1, itemtype = "2PL", method = "EM", SE=TRUE)

# Extract parameters only (a1, d, g, u)
for (i in 1:(length(items@ParObjects$pars) - 1)){
  print(i)
  if (i == 1) {
    irtparam <- coef(items)[[i]][1,1:4]
  } else {
    irtparam <- rbind(irtparam, coef(items)[[i]][1,1:4])
  }
}
rownames(irtparam) <- 1:nrow(irtparam)

IRT_Parameters <- irtparam %>% data.frame() %>%
  mutate(word_id = colnames(data_irt) %>% as.numeric()) %>%
  select(word_id, colnames(.[,1:(ncol(.)-1)]))

if (type == "WG") {
  fname8 <- paste("IRT_Parameters", lang, type, resp, sep="-")
  fname8 <- paste(fname8, "csv", sep = ".")
} else if (type == "WS") {
  fname8 <- paste("IRT_Parameters", lang, type, sep="-")
  fname8 <- paste(fname8, "csv", sep = ".")
}

readr::write_csv(IRT_Parameters, fname8)
### END of Modeling ###


REBOL [ Title: "ebeats" File: %ebeats.r ]
beats: to integer! (now/time - now/zone * 115740 / 100000)
print  join "@" beats / 100


#!/usr/bin/env Rscript
#plot tree and shared alleles of dataset only filtered for marker missingness
args = commandArgs(trailingOnly=TRUE)
if (length(args)==0) {
  stop("At least one argument must be supplied (input file).n", call.=FALSE)

WD<-getwd()
setwd(WD)
outputfile<-"Alleles_largedist"
largedist1a<- read.table ("args[1]", header = TRUE)
attach (largedist1a)
largedist2a <- as.dist(largedist1a)  #this gives a triangular matrix dist 2 is triangular matrix
largehca <- hclust(largedist2a, "average") #UPGMA

pdf (file =paste(outputfile,"_tree.pdf", sep=""), width =10, height = 5, pointsize =6)
plot(largehca, cex=0.8)
dev.off()
q()
N


myfunction <- function() {
	x <- rnorm(100)
	mean(x)
}

second <- function(x) {
	x + rnorm(length(x))
}


rttpyft<-39354
rttpskj<-92351
ssap10<-94430
ssap16<-82874

dispread<-function(file)
{
   tailstring<-paste("tail -n +3 ",file, sep="")
   print(tailstring)
   options("warn"=-1)
   disp<-read.table(pipe(tailstring),sep=",",header=T,check.names=T)
   disp
}

#udispplot<-function(fit)
#{
#  file<-paste(fit,".prn",sep="")
#  disp<-dispread(file)
#  dispplot(disp,fit,"Displacement (NMi)")
#}

xdispplot<-function(fit)
{
  file<-paste(fit,".prn",sep="")
  disp<-dispread(file)
  dispplot(disp,fit,"E-W Displacement (NMi)")
}

ydispplot<-function(fit)
{
  file<-paste(fit,".prn",sep="")
  disp<-dispread(file)
  dispplot(disp,fit,"N-S Displacement (NMi)")
}

dispplot<-function(disp,fit,xtitle)
{
   require(modreg)
   x<-as.numeric(gsub("X","",gsub("X\\.","-",names(disp)[-1])))
#  x<-as.numeric(substring(names(disp)[-1],2))
#  print(x)
   wd<-getwd()
   mtitle<-paste(wd,"/",fit,sep="")
   plot(x,disp[1,-1],type='l',xlim<-c(-1000,1000), main= mtitle,
        ylab="Number",xlab=xtitle)
   pts<-3
   fpts<-pts/length(x)
#  print(fpts)
   sdpr<-supsmu(x,as.numeric(as.vector(disp[1,-1])),span=fpts)
   lines(sdpr$x,sdpr$y,col=pts,lwd=2)
   lines(c(0,0),c(0,max(disp[1,-1])))
   lines(x,disp[3,-1])
   lines(x,disp[6,-1])
   lines(x,disp[12,-1])

   ps<-paste(fit,".ps",sep="")
   dev.copy(device=postscript, file=ps, horizontal=FALSE,
      paper="letter", height=6,width=6,pointsize=12)
   dev.off()
}

udisplot<-function(fit,releases)
{
  require(modreg)
  file<-paste(fit,".prn",sep="")
  disp<-dispread(file)
  dd<-disp[,-1]
  surv<-apply(dd,1,sum)
  deaths<- -1.0*diff(c(releases,surv))
  tt<-apply(dd,2,function(x)x*deaths/(surv+1e-8))
  x<-as.numeric(substring(names(dd),2))
  dpr<-apply(tt,2,sum)
  wd<-getwd()
  mtitle<-paste(wd,"/",fit,sep="")
  plot(x,dpr,type='l',xlim<-c(1,1000),lwd=2, main=mtitle,
       xlab="Net Displacement (NMi)",ylab="Number of Fish")
  points(x,rep(0,length(x)),pch=3)

  pts<-2
  fpts<-pts/length(x)
# print(fpts)
  sdpr<-supsmu(x,dpr,span=fpts)
  lines(sdpr$x,sdpr$y,col=pts,lwd=2)

  pts<-6
  fpts<-pts/length(x)
# print(fpts)
  sdpr<-supsmu(x,dpr,span=fpts)
  lines(sdpr$x,sdpr$y,col=pts)

  sdpr<-supsmu(x,dpr)
  lines(sdpr$x,sdpr$y)

  cdpr<-cumsum(dpr)/sum(dpr)
  cprmed<-approx(cdpr,x,.5)
  print(paste("Median displacement distance = ",cprmed$y," NMi",sep=""))
  lines(x,cdpr*max(dpr))
# lines(c(cprmed$y,cprmed$y),c(0,0.5*max(dpr)))
  arrows(cprmed$y,0.0,cprmed$y,0.5*max(dpr),code=1,angle=15,length=0.25,col="green")

  ps<-paste(fit,".ps",sep="")
  dev.copy(device=postscript, file=ps, horizontal=FALSE,
     paper="letter", height=6,width=6,pointsize=12)
  dev.off()
# wmf<-paste(fit,".wmf",sep="")
# dev.copy(device=win.metafile,filename = wmf, width = 6, height = 6,
#          pointsize=12)
# dev.off()
# pngname<-paste(fit,".png",sep="")
# dev.copy(device=png,filename=pngname)
# dev.off()
}

udisplot2<-function(fit1,fit2,releases)
{
  require(modreg)
  file<-paste(fit1,".prn",sep="")
  disp<-dispread(file)
  dd<-disp[,-1]
  surv<-apply(dd,1,sum)
  deaths<- -1.0*diff(c(releases,surv))
  tt<-apply(dd,2,function(x)x*deaths/(surv+1e-8))
  x<-as.numeric(substring(names(dd),2))
  dpr<-apply(tt,2,sum)
  sdpr<-supsmu(x,dpr)
  lsty<-"solid"
# plot(sdpr$x,sdpr$y,type='l',xlim<-c(1,1000),lwd=2,lty=lsty,
#      xlab="Net Displacement (NMi)",ylab="Number of Fish")
  cdpr<-cumsum(dpr)/sum(dpr)
  cprmed<-approx(cdpr,x,.5)
  print(paste("Median displacement distance = ",cprmed$y," NMi",sep=""))
# lines(x,cdpr*max(dpr),lty=lsty)
  plot(x,cdpr*max(dpr),type='l',xlim<-c(1,1000),ylim<-c(0,3000),lwd=1,lty=lsty,
       xlab="Net Displacement (NMi)",ylab="Number of Fish")
  arrows(cprmed$y,0.0,cprmed$y,0.5*max(dpr),code=1,angle=15,length=0.25,lwd=1,lty=lsty)

  file<-paste(fit2,".prn",sep="")
  disp<-dispread(file)
  dd<-disp[,-1]
  surv<-apply(dd,1,sum)
  deaths<- -1.0*diff(c(releases,surv))
  tt<-apply(dd,2,function(x)x*deaths/(surv+1e-8))
  x<-as.numeric(substring(names(dd),2))
  dpr<-apply(tt,2,sum)
  sdpr<-supsmu(x,dpr)
  lsty<-"dashed"
# lines(sdpr$x,sdpr$y,lwd=2,lty=lsty)
  cdpr<-cumsum(dpr)/sum(dpr)
  cprmed<-approx(cdpr,x,.5)
  print(paste("Median displacement distance = ",cprmed$y," NMi",sep=""))
  lines(x,cdpr*max(dpr),lty=lsty)
  arrows(cprmed$y,0.0,cprmed$y,0.5*max(dpr),code=1,angle=15,length=0.25,lty=lsty)
  fit<-"displacements"
  ps<-paste(fit,".ps",sep="")
  dev.copy(device=postscript, file=ps, horizontal=FALSE,
     paper="letter", height=6,width=6,pointsize=12)
  dev.off()
# wmf<-paste(fit,".wmf",sep="")
# dev.copy(device=win.metafile,filename = wmf, width = 6, height = 6,
#          pointsize=12)
# dev.off()
  pngname<-paste(fit,".png",sep="")
  dev.copy(device=png,filename=pngname)
  dev.off()
}

empdisplace<-function(file,title)
{
  recaps<-read.csv(file,header=T)
  print(paste(title, "; median = ",median(recaps$distnm),sep=""))
  mt<-paste(title, " (",median(recaps$distnm)," NMi)", sep="")
  fr<-range(0,1000)
  hist(recaps$distnm,breaks=80, xlim=fr, main=mt, xlab="Distance Traveled (Nmi)",
       ylab="Number of Tag Returns")
}

empdisp3<-function()
{
  nf<-layout(matrix(c(1,2,3),3,1,byrow=TRUE))
  layout.show(nf)
  empdisplace("SSS.csv", "SSAP Skipjack")
  empdisplace("RTS.csv", "RTTP Skipjack")
  empdisplace("RTY.csv", "RTTP Yellowfin")

  dev.copy(device=postscript, file="empdisp3.ps", horizontal=FALSE,
     paper="letter", height=9,width=6,pointsize=12)
  dev.off()

  dev.copy(device=png,file="empdisp3.png")
  dev.off()

}

comboplot<-function()
{
  releases<-rttpyft
  empfile <-paste("RTY.csv")
  print(empfile)
  title <- paste("RTTP Yellowfin")
  recaps<-read.csv(empfile,header=T)
  fr<-range(0,1000)
  oldpar <- par(no.readonly = TRUE)
  par(mar=c(5, 5, 5, 5) + 0.1)
  hist(recaps$distnm,breaks=80, xlim=fr, main=title, axes=F, xlab=NULL, ylab=NULL)
  axis(1)
  mtext(text = "Distance Traveled (Nmi)", side = 1,line=3)
  axis(2)
  mtext(text="Recaptured Tags",side=2,line=3)

  require(modreg)
  fit<-paste("fit0b_pdispl_q")
  file<-paste(fit,".prn",sep="")
  print(file)
  disp<-dispread(file)
  dd<-disp[,-1]
  surv<-apply(dd,1,sum)
  deaths<- -1.0*diff(c(releases,surv))
  tt<-apply(dd,2,function(x)x*deaths/(surv+1e-8))
  x<-as.numeric(substring(names(dd),2))
  dpr<-apply(tt,2,sum)
  sdpr<-supsmu(x,dpr)

  par(new = TRUE)
  plot(sdpr$x,sdpr$y, type = "n", xlim=fr,ylim<-c(0,3500), axes = FALSE, xlab="", ylab ="")
  lines(sdpr$x,sdpr$y,col="blue",xlab="", ylab ="",lwd=2)
  axis(4)
  mtext(text="Tags At Liberty",side=4, col="blue",line=3)

  cdpr<-cumsum(dpr)/sum(dpr)
  cprmed<-approx(cdpr,x,.5)
  print(paste("Median displacement distance = ",cprmed$y," NMi",sep=""))
# lines(x,cdpr*max(dpr))
# lines(c(cprmed$y,cprmed$y),c(0,0.5*max(dpr)))
# arrows(cprmed$y,0.0,cprmed$y,0.5*max(dpr),code=1,angle=15,length=0.25,col="green")
  box()
  par(oldpar)

  dev.copy(device=postscript, file="yft_combo.ps", horizontal=FALSE,
     paper="letter", height=6,width=6,pointsize=12)
  dev.off()
# wmf<-paste(fit,".wmf",sep="")
# dev.copy(device=win.metafile,filename = wmf, width = 6, height = 6,
#          pointsize=12)
# dev.off()
# pngname<-paste(fit,".png",sep="")
# dev.copy(device=png,filename=pngname)
# dev.off()
}


library(changepoint)
library(dplyr)

air_data <- readRDS("Air_box.rds")

sensor_ID <- unique(air_data$ID)

data_f_ID = character(0)
data_f_CP = numeric(0)
data_f_lat = numeric(0)
data_f_lon = numeric(0)
up_down = numeric (0)

for(j in 1:length(sensor_ID)){ #length(sensor_ID)
  if( j == 127 ) next #error message Data must have at least 4 observations to fit a change point model.

	PM25_of_sensor <- subset(air_data, ID == sensor_ID[j])

	del_index_arr = group_by(PM25_of_sensor, as.Date(f_time, tz = "Etc/GMT+8")) %>%
	summarise( length(PM25) > 4 ) #change point detection is not available when length is shorter than 4

	Day_ID <- unique(as.Date(PM25_of_sensor$f_time, tz = "Etc/GMT+8"))
	del_index = which(as.data.frame(del_index_arr[,2])[,1] %in% 0)

	if(length(del_index) != 0) PM25_of_sensor <- PM25_of_sensor[ -which( Day_ID[del_index] == as.Date(PM25_of_sensor$f_time, tz = "Etc/GMT+8") ),]
	#get Day_ID after deleting the ones with length shorter than 4
	Day_ID <- unique(as.Date(PM25_of_sensor$f_time, tz = "Etc/GMT+8"))

	ch_id_group = group_by(PM25_of_sensor, as.Date(f_time, tz = "Etc/GMT+8")) %>%
	summarise(
	  ifelse(length(cpt.meanvar(PM25,penalty="Manual",pen.value="4*log(n)",method="BinSeg",Q=2,class=FALSE)) == 0, NA, list(cpt.meanvar(PM25,penalty="Manual",pen.value="4*log(n)",method="BinSeg",Q=2,class=FALSE)))
	  )

	# numeric_id_in_each_day ch_id_group[[2]][[DAY_i]]
	# each_day ch_id_group[[1]][[DAY_i]]
	# sen_of_day <- PM25_of_sensor[which(as.Date(PM25_of_sensor$f_time, tz = "Etc/GMT+8") == Day_ID[DAY_i]),]
	# sen_of_day$f_time[ch_id_group[[2]][[DAY_i]]]
	if(length(Day_ID)==0) next
	my_vec = numeric (0)

	ID_of_full_length = 0
	for(Day_i in 1:length(Day_ID)){
	  The_ID = ch_id_group[[2]][[Day_i]]
	  sen_of_day <- PM25_of_sensor[which(as.Date(PM25_of_sensor$f_time, tz = "Etc/GMT+8") == Day_ID[Day_i]),]

	  for(k in 1:length(The_ID)){
	    if(is.na( PM25_of_sensor$PM25[ ID_of_full_length + The_ID[k] + 1 ] )){
	      print(ID_of_full_length + The_ID[k] + 1)
	      up_down <- append(up_down, -1) }
		  else if( (PM25_of_sensor$PM25[ ID_of_full_length + The_ID[k] ]) > (PM25_of_sensor$PM25[ ID_of_full_length + The_ID[k] + 1 ]) ) {up_down <- append(up_down, 0)}
		  else{up_down <- append(up_down, 1)}
	  }
	  my_vec <- append(my_vec, sen_of_day$f_time[The_ID])

	  ID_of_full_length <- ID_of_full_length + length(sen_of_day$PM25)
	}
	# make it as dataframe
	x <- rep(sensor_ID[j], length(my_vec))
	lat <- rep(PM25_of_sensor$Coor_x[1], length(my_vec))
	lon <- rep(PM25_of_sensor$Coor_y[1], length(my_vec))

	data_f_CP <- append(data_f_CP, my_vec)
	data_f_ID <- append(data_f_ID, as.character(x))
	data_f_lat <- append(data_f_lat, lat)
	data_f_lon <- append(data_f_lon, lon)
}
df <- data.frame(data_f_ID, data_f_CP, data_f_lat, data_f_lon, up_down)
saveRDS(df, file = "C:\\Users\\anthony\\Desktop\\Changepoint.rds")


#' @title is_leap_year
#' @description unknown
#' @family abysmally documented
#' @author  unknown, \email{<unknown>@@dfo-mpo.gc.ca}
#' @export
is_leap_year = function (yr) {
  .Deprecated(msg="Why not use lubridate::leap_year() instead?")
  #\\test to see if yr is a leap year
  yr%%4 == 0 & (yr%%100 != 0 | yr%%400 == 0 )
}


#install.packages("Rcpp")
#install.packages("anytime")
library(jsonlite)
library(hrbrthemes)
library(tidyverse)
library(dplyr)
library(anytime)

# the wallets address accepting ransom payments for petya ransomware from thegaurdian.com

wallets <- c(
  "1Mz7153HMuxXTuR2R1t78mGSdzaAtNbBWX"
)

# easy way to get each wallet info vs bringing in the Rbitcoin package

sprintf("https://blockchain.info/rawaddr/%s", wallets) %>%
  map(jsonlite::fromJSON) -> chains

# get the current USD conversion (tho the above has this, too)

curr_price <- jsonlite::fromJSON("https://blockchain.info/ticker")

# calculate some basic stats

tot_bc <- sum(map_dbl(chains, "total_received")) / 10e7
tot_usd <- tot_bc * curr_price$USD$last
tot_xts <- sum(map_dbl(chains, "n_tx"))

# This needs to be modified once the counters go above 100 and also needs to
# account for rate limits in the blockchain.info API

paged <- which(map_dbl(chains, "n_tx") > 50)
if (length(paged) > 0) {
  sprintf("https://blockchain.info/rawaddr/%s?offset=50", wallets[paged]) %>%
    map(jsonlite::fromJSON) -> chains2
}

# We want hourly data across all transactions

map_df(chains, "txs") %>%
  bind_rows(map_df(chains2, "txs")) %>%
  mutate(xts = anytime::anytime(time),
         xts = as.POSIXct(format(xts, "%Y-%m-%d %H:00:00"), origin="GMT")) %>%
  count(xts) -> xdf

# Plot it

ggplot(xdf, aes(xts, y = n)) +
  geom_col() +
  scale_y_comma(limits = c(0, max(xdf$n))) +
  labs(x = "Day/Time (GMT)", y = "# Transactions",
       title = "Bitcoin Payments-per-hour summary for Petya Ransomware",
       subtitle=sprintf("%s transactions to-date; %s total bitcoin; %s USD; Chart generated at: %s EDT",
                        scales::comma(tot_xts), tot_bc, scales::dollar(tot_usd), Sys.time())) +
  theme_ipsum_rc(grid="Y")


library(Seurat)
# library(reticulate)
# use_python("/Users/cuizhe/anaconda3/bin/python",required = TRUE)
setwd("/Users/cuizhe/project_local/2020-06-21-seurat-rna-seq-10x-5k-v3")
# load 10x nextgem pbmc data
counts <- Read10X_h5("./tmp5k_nextgem3.0.2/5k_pbmc_v3_nextgem_filtered_feature_bc_matrix.h5")
rownames(counts) <- make.unique(rownames(counts))
rna <- CreateSeuratObject(counts = counts, assay = 'RNA', min.cells = 5, min.features = 500, project = '10x_RNA')
rna <- RenameCells(rna, add.cell.id = 'rna')
mito.features <- grep(pattern = "^MT-", x = rownames(x = rna), value = TRUE)
percent.mito <- Matrix::colSums(x = GetAssayData(object = rna, slot = 'counts')[mito.features, ]) / Matrix::colSums(x = GetAssayData(object = rna, slot = 'counts'))
rna$percent.mito <- percent.mito

# QC
rna <- subset(x = rna, subset = nCount_RNA > 2000 & nCount_RNA < 20000 & percent.mito < 0.2)

# preprocessing
rna <- NormalizeData(rna)
rna <- FindVariableFeatures(rna, nfeatures = 3000)
rna <- ScaleData(rna)
rna <- RunPCA(rna, npcs = 100)
rna <- RunTSNE(rna, dims = 1:30)
rna <- FindNeighbors(rna, dims = 1:30)
rna <- FindClusters(rna, resolution = 0.4, algorithm = 3)
rna <- RunUMAP(rna, graph = 'RNA_nn', metric = 'euclidean')

DimPlot(rna, reduction = "umap")
rna.markers <- FindAllMarkers(rna, only.pos = TRUE, min.pct = 0.25, logfc.threshold = 0.25)
View(rna.markers %>% group_by(cluster) %>% top_n(n = 20, wt = avg_logFC))
top10 <- rna.markers %>% group_by(cluster) %>% top_n(n = 10, wt = avg_logFC)
DoHeatmap(rna, features = top10$gene) + NoLegend()
FeaturePlot(rna, features = c("IL7R","CCR7","S100A4","CD14","LYZ","MS4A1","CD8A","FCGR3A","MS4A7", "GNLY","NKG7", "FCER1A", "CST3","PPBP"))

new.cluster.ids <- c(
  "Naive CD4+ T",
  'CD14+ Mono',
  'Memory CD4+',
  'NK',
  'NK',
  'B',
  'B',
  'CD8+ T',
  'FCGR3A+ Mono',
  'NK',
  'DC',
  'Platelet')

names(x = new.cluster.ids) <- levels(x = rna)
rna <- RenameIdents(object = rna, new.cluster.ids)
rna$celltype <- Idents(rna)
nk.cells <- subset(rna, subset = celltype == 'NK')
gzmk <- GetAssayData(nk.cells, assay = 'RNA', slot = 'data')['GZMK', ]
nk.cells$bright <- ifelse(gzmk > 1, 'NK bright', 'NK dim')
ctypes <- as.vector(rna$celltype)
names(ctypes) <- names(rna$celltype)
ctypes[Cells(nk.cells)] <- nk.cells$bright
rna <- AddMetaData(rna, metadata = ctypes, col.name = 'celltype')
saveRDS(rna, "./tmp5k_nextgem3.0.2/pbmc_5k_nextgem.rds")


# Use XGB binary prediction model on raster data

rasterXgb <- function(xgbModel, rData, nLayers) {

    for (i in 1:nLayers) {
        rastPred[i,] <- predict(xgbModel, rData[i,], missing=NA)
        print("Current rasterXgb loop iteration: ", i)
    }
}


# Data Visualization with ggplot
# Reading Datasets with read_csv
# Video 1.3

# This course assumes that you already have the Tidyverse and ggmap libraries installed
# on your system.  If you do not, uncomment and execute the lines below.

#install.packages("tidyverse")
#install.packages("ggmap")

# Load the Tidyverse
library(tidyverse)

# Read the college dataset
college <- read_csv('http://672258.youcanlearnit.net/college.csv')

# Take a look at the data
summary(college)

# Convert state, region, highest_degree, control, and gender to factors
college <- college %>%
  mutate(state=as.factor(state), region=as.factor(region),
         highest_degree=as.factor(highest_degree),
         control=as.factor(control), gender=as.factor(gender))

# Take a look at the data
summary(college)

# What's going on with loan_default_rate?
unique(college$loan_default_rate)

# Let's just force that to numeric and the "NULL" will convert to N/A
college <- college %>%
  mutate(loan_default_rate=as.numeric(loan_default_rate))

# Take a look at the data
summary(college)


# Information about code:
# This code corresponds to a chapter in my MSc thesis for
# Chapter 3, the section on Gender analysis: data aquisition
# @@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@

# Libraries
library(httr)

# @@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@
# Section - get UN data
# @@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@
print(paste0(Sys.time(), " --- get UN data"))

# http://ec2-54-174-131-205.compute-1.amazonaws.com/API/Information.php

indicators <- list(`24106` = "schl_f", # GDI: Mean years of schooling (females aged 25 years and above)
                   `24206` = "schl_m", # GDI: Mean years of schooling (males aged 25 years and above)
                   `120606`= "lexp_f", # GDI: Life expectancy at birth, female
                   `121106`= "lexp_m", # GDI: Life expectancy at birth, male
                   `123306`= "esch_f", # GDI: Expected years of schooling, females
                   `123406`= "esch_m", # GDI: Expected years of schooling, males
                   `123506`= "gnip_f", # GDI: Estimated GNI per capita (PPP), female
                   `123606`= "gnip_m", # GDI: Estimated GNI per capita (PPP), male
                   `137906`= "gdip_a"  # GDI
)
query_indicator <- do.call(paste, c(as.list(names(indicators)), sep = ","))
path <- paste0(
    "http://ec2-54-174-131-205.compute-1.amazonaws.com/API/HDRO_API.php/indicator_id=",
    query_indicator, "/year=1990,2017/structure=cyi")

request <- GET(url = path)
request$status_code
response <- content(request, as = "text", encoding = "UTF-8")
parsed_json <- fromJSON(response, flatten = TRUE)

df <-  parsed_json$indicator_value %>% data.frame() %>% t() %>% data.frame()
df$col <- rownames(df)
df <- data.table(df)
df[, c('country', 'year', 'indicator') := tstrsplit(col, ".", fixed=TRUE)]
names(df)[which(names(df)==".")] <- "value"

df_r <- dcast(df[year==2017], country ~ indicator, value.var="value")

names(df_r) <- unlist(sapply(names(df_r), function(name) {
    # print(name)
    if(name %in% names(indicators)) {
        indicators[name]
     } else { name }
}))

cols <- c("A-3", "Country")
lu <- get_lp_statoid()[, ..cols]
df_r <- merge(df_r, lu, by.x="country", by.y="A-3", all.x=T, all.y=F); rm(lu)
df_r <- df_r[!is.na(country)]

un_path <- "data/2019-11-11-un-indicators/"
dir.create(un_path)
filename_write = paste0(un_path, '2019-11-12-indicators.csv')
write.csv(df_r, filename_write, na='', row.names=F, fileEncoding="UTF-8")


library(Romp)

n <- 20000

truth <- 2262
c <- c_primesbelow(n)
f77 <- f77_primesbelow(n)
f90 <- f90_primesbelow(n)
rcpp <- rcpp_primesbelow(n)

stopifnot(all.equal(truth, c))
stopifnot(all.equal(truth, f77))
stopifnot(all.equal(truth, f90))
stopifnot(all.equal(truth, rcpp))


#!/usr/bin/env Rscript
args = commandArgs(trailingOnly=TRUE)

firstFile = args[1]
numFiles = as.integer(args[2])
ratioFile = args[3]

numRatios = ncol(read.table(ratioFile))
rows = nrow(read.table(firstFile))
colm = ncol(read.table(firstFile))

concatMatrix <- matrix(nrow=numRatios, ncol=colm)

fileName <- substr(firstFile,1, nchar(firstFile)-16)
numExec <- substr(firstFile, nchar(firstFile)-13, nchar(firstFile))

ratios = read.table(ratioFile)

for( h in 1:numRatios){
    currFile = paste( fileName, ratios[,h], numExec, sep="")
    concatMatrix[h,1] = ratios[,h] / 10
    for( i in 2:colm) {
        concatMatrix[h,i] = read.table(currFile)[rows,i]
    }
}

output <- paste(fileName, numFiles,"_statRatios.out",sep="");

write.table(format(concatMatrix, digits = 4, scientific = F, trim = T, drop0trailing = T), quote = F, file=output, row.names=F, col.names=F, sep = "\t")


# palisades dot lakes at gmail dot com
# 2018-10-09
#-----------------------------------------------------------------
if (file.exists('e:/porta/projects/xfp')) {
  setwd('e:/porta/projects/xfp')
} else {
  setwd('c:/porta/projects/xfp')
}
source('src/scripts/R/functions.r')
#-----------------------------------------------------------------
data.folder <- file.path('data','interpolate','macro')
plot.folder <- file.path('plots','interpolate','macro')
data.files <- list.files(
  path=data.folder,pattern='*.macro.tsv',full.names=FALSE)
#-----------------------------------------------------------------
for (data.file in data.files) {
  data <- read.tsv(file.path(data.folder,data.file))
  print(nrow(data))
  data$functional <- factor(x=data$functional,levels=functionals)
  knots <-
    data[(data$functional=='argmin') |
        (data$functional=='valueKnot') |
        (data$functional=='slopeKnot') ,]
  curves <-
    data[(data$functional!='argmin') &
        (data$functional!='valueKnot') &
        (data$functional!='slopeKnot') ,]
  dev.on(
    file=file.path(plot.folder,data.file),
    aspect=1016/1856,
    width=1856)
  plot <- ggplot(curves, aes(x=x, y=y, color=functional)) +
    geom_point(data=knots,size=4.0) +
    geom_line(size=1.0) +
  scale_color_manual(values=(functional.colors),drop=FALSE) +
  theme(text=element_text(size=24))#+
  #ggtitle("lower is better")
  print(plot)
  dev.off() }
#-----------------------------------------------------------------


library(pheatmap) # heatmap packages

# read the file
x1= read.delim("E:/denboer2009-expr.txt")
rownames(x1)= x1[,1]
x3 = x1[,-1]
x= as.data.frame(t(x3))

# plot & save heatmap
jpeg("Heatmap.jpg")
pheatmap(x)
dev.off


get.ancestry.structure <- function(node, edge){
  if(!is.vector(node))
    stop("'node' must be a vector with length 1 or more")

  if(!is.numeric(node) | !is.numeric(edge))
    stop("'node' and 'edge' must be numeric")

  if(!is.matrix(edge))
    stop("'edge' must be a matrix")

  if(sum(node %in% edge) == 0)
    stop("'node' is not in 'edge'")

  # descendants
  desc <- c()

  # node with multiples descendants
  nwmd <- matrix(NA, nrow = length(node), ncol = 2,
                 dimnames = list(1:length(node), c('node', 'nwmd')))
  nwmd[ ,1] <- node

  for(i in node){
    # descendant node
    dn <- edge[edge[ ,2] %in% i,1]
    # number of descendants
    nod <- edge[edge[ ,1] %in% dn,1]
    while(length(nod)){
      if(length(nod) < 2){
        desc <- c(desc, dn)
        dn <- edge[edge[ ,2] %in% dn,1]
        nod <- edge[edge[ ,1] %in% dn,1]
      } else {
        nwmd[nwmd[ ,1] %in% i,2] <- dn
        break
      }
    }
  }

  return(list(u_desc = desc,
              m_desc = nwmd))
}


#Create some basic summary plots for Wikimedia configuration changes
library(plyr)
library(ggplot2)
library(RColorBrewer)
library(grid)
library(scales)

setwd(dirname(sys.frame(1)$ofile))
theme_update(plot.margin = unit(c(0,0,0,0), "cm"))

times = read.csv("times.csv", header=FALSE)

times$date = as.Date(as.POSIXlt(times$V1, origin="1970-01-01"), tz="America/New_York")
ggplot(times, aes(x=date)) + geom_histogram(binwidth=1) +
  scale_x_date(labels=date_format("%m/%d/%y"), breaks="2 weeks") +
  theme(axis.text.x=element_text(angle=45, hjust=1)) +
  scale_y_continuous("Number of Configuration Changes")
ggsave("figs/config-changes-bydate.pdf", width=15, height=6)

times$days = weekdays(times$date, abbreviate=TRUE)
times$days = factor(times$days, levels=c("Mon", "Tue", "Wed", "Thu", "Fri", "Sat", "Sun"))
ggplot(times, aes(x=days)) + geom_histogram(binwidth=1) +
  scale_y_continuous("Number of configuration changes")
ggsave("figs/config-changes-byweekday.pdf", width=4, height=4)

files = read.csv("files.csv", header=FALSE)
files$fno=as.numeric(files$V1)
fhist=hist(files$fno, breaks=nrow(files), plot=FALSE)
counts=data.frame(
  x=seq(1, length(fhist$counts), 1),
  y=sort(fhist$counts, decreasing=TRUE)
)
ggplot(counts, aes(x, y)) + geom_line() +
  scale_y_log10("Number of Changes") + scale_x_continuous("Configuration File Number")
ggsave("figs/config-changes-byfile.pdf", width=4, height=3)
ggplot(counts, aes(x, y)) + geom_line() +
  scale_y_log10("Number of Changes") + scale_x_log10("Configuration File Number")
ggsave("figs/config-changes-byfile-logx.pdf", width=4, height=3)

ftable = sort(table(as.character(files$V1)), decreasing=TRUE)


################################################################################
### R script to compare several conditions with the SARTools and DESeq2 packages
### Hugo Varet
### March 20th, 2018
### designed to be executed with SARTools 1.6.6
################################################################################

################################################################################
###                parameters: to be modified by the user                    ###
################################################################################
rm(list=ls())                                        # remove all the objects from the R session

workDir <- "~/Git/Project3/SARTools/SARTools.DESeq2.genes.batch.r"      # working directory for the R session

projectName <- "SARTools.DESeq2.genes"                         # name of the project
author <- "CheyenneMoore"                                # author of the statistical analysis/report

targetFile <- "../genes.target.txt"                           # path to the design/target file
rawDir <- "../"                                      # path to the directory containing raw counts files
featuresToRemove <- NULL
varInt <- "Treatment"                                    # factor of interest
condRef <- "Untreated"                                      # reference biological condition
batch <- "batch"                                        # blocking factor: NULL (default) or "batch" for example

idColumn = 1                                         # column with feature Ids (usually 1)
countColumn = 5                                      # column with counts  (2 for htseq-count, 7 for featurecounts, 5 for RSEM/Salmon, 4 for kallisto)
rowSkip = 0                                          # rows to skip (not including header)

fitType <- "parametric"                              # mean-variance relationship: "parametric" (default), "local" or "mean"
cooksCutoff <- TRUE                                  # TRUE/FALSE to perform the outliers detection (default is TRUE)
independentFiltering <- TRUE                         # TRUE/FALSE to perform independent filtering (default is TRUE)
alpha <- 0.05                                        # threshold of statistical significance
pAdjustMethod <- "BH"                                # p-value adjustment method: "BH" (default) or "BY"

typeTrans <- "VST"                                   # transformation for PCA/clustering: "VST" or "rlog"
locfunc <- "median"                                  # "median" (default) or "shorth" to estimate the size factors

colors <- c("dodgerblue","firebrick1",               # vector of colors of each biological condition on the plots
            "MediumVioletRed","SpringGreen")

forceCairoGraph <- FALSE

################################################################################
###                             running script                               ###
################################################################################
setwd(workDir)

if (!require("BiocManager")) install.packages("BiocManager"); library(BiocManager)
if (!require("DESeq2")) BiocManager::install("DESeq2"); library(DESeq2)
if (!require("edgeR")) BiocManager::install("edgeR"); library(edgeR)
if (!require("genefilter")) BiocManager::install("genefilter"); library(genefilter)

# PC Users only, install Rtools https://cran.r-project.org/bin/windows/Rtools/

if (!require("devtools")) install.packages("devtools"); library(devtools)
if (!require("SARTools")) install_github("KField-Bucknell/SARTools", build_vignettes=TRUE, force=TRUE); library(SARTools)
if (forceCairoGraph) options(bitmapType="cairo")

# checking parameters
checkParameters.DESeq2(projectName=projectName,author=author,targetFile=targetFile,
                       rawDir=rawDir,featuresToRemove=featuresToRemove,varInt=varInt,
                       condRef=condRef,batch=batch,fitType=fitType,cooksCutoff=cooksCutoff,
                       independentFiltering=independentFiltering,alpha=alpha,pAdjustMethod=pAdjustMethod,
                       typeTrans=typeTrans,locfunc=locfunc,colors=colors)

# loading target file
target <- loadTargetFile(targetFile=targetFile, varInt=varInt, condRef=condRef, batch=batch)

# loading counts
counts <- loadCountData(target=target, rawDir=rawDir, featuresToRemove=featuresToRemove,
                        skip=rowSkip, idColumn=idColumn, countColumn=countColumn)

# description plots
majSequences <- descriptionPlots(counts=counts, group=target[,varInt], col=colors)

# analysis with DESeq2
out.DESeq2 <- run.DESeq2(counts=counts, target=target, varInt=varInt, batch=batch,
                         locfunc=locfunc, fitType=fitType, pAdjustMethod=pAdjustMethod,
                         cooksCutoff=cooksCutoff, independentFiltering=independentFiltering, alpha=alpha)

# PCA + clustering
exploreCounts(object=out.DESeq2$dds, group=target[,varInt], typeTrans=typeTrans, col=colors)

# summary of the analysis (boxplots, dispersions, diag size factors, export table, nDiffTotal, histograms, MA plot)
summaryResults <- summarizeResults.DESeq2(out.DESeq2, group=target[,varInt], col=colors,
                                          independentFiltering=independentFiltering,
                                          cooksCutoff=cooksCutoff, alpha=alpha)

# save image of the R session
save.image(file=paste0(projectName, ".RData"))

# generating HTML report
writeReport.DESeq2(target=target, counts=counts, out.DESeq2=out.DESeq2, summaryResults=summaryResults,
                   majSequences=majSequences, workDir=workDir, projectName=projectName, author=author,
                   targetFile=targetFile, rawDir=rawDir, featuresToRemove=featuresToRemove, varInt=varInt,
                   condRef=condRef, batch=batch, fitType=fitType, cooksCutoff=cooksCutoff,
                   independentFiltering=independentFiltering, alpha=alpha, pAdjustMethod=pAdjustMethod,
                   typeTrans=typeTrans, locfunc=locfunc, colors=colors)


user <- Sys.getenv("USER")
hostname <- readLines("/etc/hostname")
kernel <- strsplit(readLines("/proc/version"), " ")[[1]][3]
term <- Sys.getenv("TERM")
shell <- Sys.getenv("SHELL")
tasks <- length(dir("/proc")[ grepl("^[0-9]{1,}$", dir("/proc")) ])

mem <- readLines("/proc/meminfo")
total <- as.numeric(strsplit(mem[1], "\\D+")[[1]][-1]) %/% 1000
avail <- as.numeric(strsplit(mem[3], "\\D+")[[1]][-1]) %/% 1000

uptime <- as.numeric(strsplit(readLines("/proc/uptime"), " ")[[1]][1])
d <- trunc(((uptime / 60) / 60) / 24)
h <- trunc(((uptime / 60) / 60) %% 24)
m <- trunc((uptime / 60) %% 60)

cat(user, "@", hostname,
    "\nkernel\t", kernel,
    "\nterm\t", term,
    "\nshell\t", shell,
    "\ntasks\t", tasks,
    "\nmem\t", avail, "m / ", total, "m",
    "\nuptime\t", d, "d ", h, "h ", m, "m", "\n",
    sep="")


#!/usr/bin/env Rscript

#
# load needed packages (assumption: packages are installed)
#
library(dplyr)

#
# Script Strategy
#
# Read and tidy Train UHR source data (test and train sets) -> UHR_Tidy_DF
#   1) read data in using "read.table", since the input file are not completeley
#      clean, i.e. they use both single and double spaces as field delimiters
#      inside each record
#   2) map activity codes to activity labels
#   3) change column names, accoding to CodeBook.txt, in order to have
#     descriptive names
#   4) join data in a single Dataframe
#
#   Iterations are performed on the two sets of data, using a simple vector to
#   drive them, and consolidating data in target dataframe  in order to have
#   code there is more maintanable.
#   Temporary Dataframes are generated, they could be elimited by refactoring the
#   code, in order to reduce memory usage during elaboration, if needed

# see https://stackoverflow.com/questions/16979858/reading-text-file-with-multiple-space-as-delimiter-in-r

#
# define subset of columns, from source, to be selected. Original column name
# is included, as comment, for reference and review purpose
#
  Tidy_UHR_Source_Columns <- c(
    1, # tBodyAcc-mean()-X
    2, # tBodyAcc-mean()-Y
    3, # tBodyAcc-mean()-Z
    4, # tBodyAcc-std()-X
    5, # tBodyAcc-std()-Y
    6, # tBodyAcc-std()-Z
    41, # tGravityAcc-mean()-X
    42, # tGravityAcc-mean()-Y
    43, # tGravityAcc-mean()-Z
    44, # tGravityAcc-std()-X
    45, # tGravityAcc-std()-Y
    46, # tGravityAcc-std()-Z
    81, # tBodyAccJerk-mean()-X
    82, # tBodyAccJerk-mean()-Y
    83, # tBodyAccJerk-mean()-Z
    84, # tBodyAccJerk-std()-X
    85, # tBodyAccJerk-std()-Y
    86, # tBodyAccJerk-std()-Z
    121, # tBodyGyro-mean()-X
    122, # tBodyGyro-mean()-Y
    123, # tBodyGyro-mean()-Z
    124, # tBodyGyro-std()-X
    125, # tBodyGyro-std()-Y
    126, # tBodyGyro-std()-Z
    161, # tBodyGyroJerk-mean()-X
    162, # tBodyGyroJerk-mean()-Y
    163, # tBodyGyroJerk-mean()-Z
    164, # tBodyGyroJerk-std()-X
    165, # tBodyGyroJerk-std()-Y
    166, # tBodyGyroJerk-std()-Z
    201, # tBodyAccMag-mean()
    202, # tBodyAccMag-std()
    214, # tGravityAccMag-mean()
    215, # tGravityAccMag-std()
    227, # tBodyAccJerkMag-mean()
    228, # tBodyAccJerkMag-std()
    240, # tBodyGyroMag-mean()
    241, # tBodyGyroMag-std()
    253, # tBodyGyroJerkMag-mean()
    254, # tBodyGyroJerkMag-std()
    266, # fBodyAcc-mean()-X
    267, # fBodyAcc-mean()-Y
    268, # fBodyAcc-mean()-Z
    269, # fBodyAcc-std()-X
    270, # fBodyAcc-std()-Y
    271, # fBodyAcc-std()-Z
    345, # fBodyAccJerk-mean()-X
    346, # fBodyAccJerk-mean()-Y
    347, # fBodyAccJerk-mean()-Z
    348, # fBodyAccJerk-std()-X
    349, # fBodyAccJerk-std()-Y
    350, # fBodyAccJerk-std()-Z
    424, # fBodyGyro-mean()-X
    425, # fBodyGyro-mean()-Y
    426, # fBodyGyro-mean()-Z
    427, # fBodyGyro-std()-X
    428, # fBodyGyro-std()-Y
    429, # fBodyGyro-std()-Z
    503, # fBodyAccMag-mean()
    504, # fBodyAccMag-std()
    516, # fBodyBodyAccJerkMag-mean()
    517, # fBodyBodyAccJerkMag-std()
    529, # fBodyBodyGyroMag-mean()
    530, # fBodyBodyGyroMag-std()
    542, # fBodyBodyGyroJerkMag-mean()
    543 # fBodyBodyGyroJerkMag-std()
  )
#
# define Column Names for Tidy Dataset, according to CodeBook
#
  Tidy_UHR_Column_Names <- c(
    "Subject",
    "ActivityClass",
    "Time_BodyAcc_mean_X",
    "Time_BodyAcc_mean_Y",
    "Time_BodyAcc_mean_Z",
    "Time_BodyAcc_std_X",
    "Time_BodyAcc_std_Y",
    "Time_BodyAcc_std_Z",
    "Time_GravityAcc_mean_X",
    "Time_GravityAcc_mean_Y",
    "Time_GravityAcc_mean_Z",
    "Time_GravityAcc_std_X",
    "Time_GravityAcc_std_Y",
    "Time_GravityAcc_std_Z",
    "Time_BodyAccJerk_mean_X",
    "Time_BodyAccJerk_mean_Y",
    "Time_BodyAccJerk_mean_Z",
    "Time_BodyAccJerk_std_X",
    "Time_BodyAccJerk_std_Y",
    "Time_BodyAccJerk_std_Z",
    "Time_BodyGyro_mean_X",
    "Time_BodyGyro_mean_Y",
    "Time_BodyGyro_mean_Z",
    "Time_BodyGyro_std_X",
    "Time_BodyGyro_std_Y",
    "Time_BodyGyro_std_Z",
    "Time_BodyGyroJerk_mean_X",
    "Time_BodyGyroJerk_mean_Y",
    "Time_BodyGyroJerk_mean_Z",
    "Time_BodyGyroJerk_std_X",
    "Time_BodyGyroJerk_std_Y",
    "Time_BodyGyroJerk_std_Z",
    "Time_BodyAccMag_mean",
    "Time_BodyAccMag_std",
    "Time_GravityAccMag_mean",
    "Time_GravityAccMag_std",
    "Time_BodyAccJerkMag_mean",
    "Time_BodyAccJerkMag_std",
    "Time_BodyGyroMag_mean",
    "Time_BodyGyroMag_std",
    "Time_BodyGyroJerkMag_mean",
    "Time_BodyGyroJerkMag_std",
    "Freq_BodyAcc_mean_X",
    "Freq_BodyAcc_mean_Y",
    "Freq_BodyAcc_mean_Z",
    "Freq_BodyAcc_std_X",
    "Freq_BodyAcc_std_Y",
    "Freq_BodyAcc_std_Z",
    "Freq_BodyAccJerk_mean_X",
    "Freq_BodyAccJerk_mean_Y",
    "Freq_BodyAccJerk_mean_Z",
    "Freq_BodyAccJerk_std_X",
    "Freq_BodyAccJerk_std_Y",
    "Freq_odyAccJerk_std_Z",
    "Freq_BodyGyro_mean_X",
    "Freq_BodyGyro_mean_Y",
    "Freq_BodyGyro_mean_Z",
    "Freq_BodyGyro_std_X",
    "Freq_BodyGyro_std_Y",
    "Freq_BodyGyro_std_Z",
    "Freq_BodyAccMag_mean",
    "Freq_BodyAccMag_std",
    "Freq_BodyBodyAccJerkMag_mean",
    "Freq_BodyBodyAccJerkMag_std",
    "Freq_BodyBodyGyroMag_mean",
    "Freq_BodyBodyGyroMag_std",
    "Freq_BodyBodyGyroJerkMag_mean",
    "Freq_BodyBodyGyroJerkMag_std"
  )

Activity_Columns <- c("ID") # use descriptive column names
Activity_Labels_Columns <- c("ID", "Label") # use descriptive column names
Subject_Columns <- c("ID") # use descriptive column names

#
# create empty dataframe with properly named columns
#

UHR_Tidy_DF <- read.table(text = "", col.names = Tidy_UHR_Column_Names)

#
# data will be read with path relative to current working directory
#

UHR_Data_Source_Root <- paste0(getwd(), .Platform$file.sep, "UCI HAR Dataset")

#
# get Activity Labels text
#
activity_labels_filename <-
  paste0(UHR_Data_Source_Root, .Platform$file.sep, "activity_labels.txt")
activity_label <-
    read.table(
      activity_labels_filename,
      col.names = Activity_Labels_Columns)

# iterate on different data sets and combine them in target Dataframe

data_sets <- c("test", "train" )

for (src in data_sets) {

  print(paste("Reading set", src))

#
# generate specific  source filenames
#
  subject_filename <- paste0(UHR_Data_Source_Root, .Platform$file.sep, src, .Platform$file.sep, "subject_", src, ".txt")
  activity_filename <- paste0(UHR_Data_Source_Root, .Platform$file.sep, src, .Platform$file.sep, "y_", src, ".txt")
  data_filename <- paste0(UHR_Data_Source_Root, .Platform$file.sep, src, .Platform$file.sep, "X_", src, ".txt")

#
# get data in separate dataframes
#
  subject_src <- read.table(subject_filename, col.names = Subject_Columns)
  activity_src <- read.table(activity_filename, col.names = Activity_Columns)
  data_src <- read.table(data_filename)

#
# decode activities' codes into explict labels
#
  activity_src$ID <- activity_label$Label[match(activity_src$ID, activity_label$ID)]

#
# select relevant columns from source data
#
  data_selection_src <- data_src[, Tidy_UHR_Source_Columns]

#
# create temporary set Dataframe, with properly named columns
#
  set_df <- data.frame(subject_src, activity_src, data_selection_src)
  names(set_df) <- names(UHR_Tidy_DF)

  print(paste(src, "data set: ",nrow(set_df)))

#
# append data to Tidy Dataframe
#
  UHR_Tidy_DF <- rbind(UHR_Tidy_DF, set_df)

} # scan and build the UHR Tidtìy Dataframe

#
# UHR Tidy dataset is ready
#
print(paste(src, "UHR Tidy data set: ",nrow(UHR_Tidy_DF)))

#
# Since the dataset is now tidy, we can summarize it usign dplyr pipes!
# Summarise by average (using mean), against Activty and Subject
#

UHR_Average_DF <- UHR_Tidy_DF %>%
                      group_by(ActivityClass, Subject) %>%
                      summarise_all(mean)

#
# update column names according to CodeBook
#

colnames(UHR_Average_DF) <-
    c(colnames(UHR_Average_DF[1:2]),
      paste0(colnames(UHR_Average_DF[3:ncol(UHR_Average_DF)]), "_avg"))

print(paste(src, "UHR Tidy Averag dataset: ",nrow(UHR_Average_DF)))

print("Done")


library(tidyverse)
library(RColorBrewer)
library(rgeos)
library(maptools)
library(scales)

#set path
path_inputs <- "C:\\Users\\edwar\\Desktop\\GitHub\\digital_comms\\results\\digital_transport"
path_shapes <- "C:\\Users\\edwar\\Desktop\\GitHub\\digital_comms\\data\\digital_comms\\raw\\simplified_LADs"
path_figures <- "C:\\Users\\edwar\\Dropbox\\DfT ITS Project\\figures"

#set working directory
setwd(path_inputs)

# Get the files names
files = list.files(pattern=glob2rx("sensitivity_isd_spend_*.csv"))

# First apply read.csv, then rbind
all_scenarios = do.call(rbind, lapply(files, function(x) read.csv(x, stringsAsFactors = FALSE)))

cut_down_data <- select(all_scenarios, scenario, strategy, wtp_scenario, isd,
                         RAN_units, small_cell_mounting_points, fibre_backhaul_m, length_m, total_tco)

cut_down_data <- cut_down_data %>%
  group_by(scenario, strategy, wtp_scenario, isd) %>%
  summarise(RAN_units = sum(RAN_units),
            small_cell_mounting_points = sum(small_cell_mounting_points),
            fibre_backhaul= sum(fibre_backhaul_m),
            length_m = sum(length_m),
            total_tco = round(sum(total_tco),1))

strategy_labels <- c(`cellular_V2X_full_greenfield` = "Greenfield Cellular V2X",
                     `cellular_V2X_NRTS` = "Cellular V2X with NRTS",
                     `DSRC_full_greenfield` = "Greenfield DSRC",
                     `DSRC_NRTS` = "DSRC with NRTS")

scenario_labels <- c(`high` = "High (10 Mb/s, £20 ARPU)",
                     `baseline` = "Baseline (4 Mb/s, £4 ARPU)",
                     `low` = "Low (1 Mb/s, £2 ARPU)")

aggregate_cost <- cut_down_data %>%
  group_by(scenario, strategy, wtp_scenario, isd) %>%
  mutate(RAN_per_m = round(RAN_units / length_m, 5),
         ISD = round(length_m / RAN_units, 5),
            mounting_points_per_m = round(small_cell_mounting_points / length_m, ),
            fibre_backhaul_m = fibre_backhaul/ length_m,
            length_m = length_m,
            cost_per_m = round(total_tco / length_m, 6),
            total_tco = round(sum(total_tco), 3))  %>%
  select(scenario, strategy, wtp_scenario, isd, RAN_per_m, ISD, mounting_points_per_m, cost_per_m, total_tco)

aggregate_cost <- aggregate_cost[(aggregate_cost$ISD < 5000),]

aggregate_cost$scenario <- factor(aggregate_cost$scenario,
                           levels = c("high",
                                      "baseline",
                                      "low"))

ISD <- ggplot(aggregate_cost, aes(x=ISD, y=total_tco/1000000000, group=1)) + geom_line() +
  scale_y_continuous(expand = c(0, 0), limits=c(0,21)) +
  scale_x_continuous(expand = c(0, 0), limits=c(0,4999)) +
  xlab("Mean Inter-Site Distance (ISD) (m)") +
  ylab("Investment Cost (Billions GBP)") +
  labs(title="Sensitivity of Total Cost to Mean Inter-Site Distance (ISD)", subtitle="Results reported by scenario and strategy as mean ISD increases") +
  facet_grid(scenario~strategy, labeller = labeller(strategy = strategy_labels, scenario = scenario_labels))

### EXPORT TO FOLDER
setwd(path_figures)
tiff('ISD.tiff', units="in", width=8, height=9, res=300)
print(ISD)
dev.off()

mean_cost <- aggregate_cost %>%
              group_by(scenario, strategy, wtp_scenario) %>%
              summarise(cost = round(mean(total_tco)/1000000000,2))

rm(aggregate_cost, all_scenarios, cut_down_data, ISD, mean_cost, files)

###############################
# PENETRATION
###############################

#set working directory
setwd(path_inputs)

# Get the files names
files = list.files(pattern=glob2rx("sensitivity_penetration_spend_*.csv"))

# First apply read.csv, then rbind
all_scenarios = do.call(rbind, lapply(files, function(x) read.csv(x, stringsAsFactors = FALSE)))

cut_down_data <- select(all_scenarios, scenario, strategy, wtp_scenario, inflection_year,
                        annual_CAV_take_up, CAV_revenue)

aggregate_cost <- cut_down_data %>%
  group_by(scenario, strategy, wtp_scenario, inflection_year) %>%
  summarise(annual_CAV_take_up = sum(annual_CAV_take_up),
                   CAV_revenue = sum(CAV_revenue)/1000000000)

strategy_labels <- c(`cellular_V2X_full_greenfield` = "Greenfield Cellular V2X",
                     `cellular_V2X_NRTS` = "Cellular V2X with NRTS",
                     `DSRC_full_greenfield` = "Greenfield DSRC",
                     `DSRC_NRTS` = "DSRC with NRTS")

scenario_labels <- c(`high` = "High (10 Mb/s, £20 ARPU)",
                     `baseline` = "Baseline (4 Mb/s, £4 ARPU)",
                     `low` = "Low (1 Mb/s, £2 ARPU)")

# aggregate_cost <- cut_down_data %>%
#   group_by(scenario, strategy, wtp_scenario, inflection_year) %>%
#   mutate(annual_CAV_take_up = sum(annual_CAV_take_up),
#          CAV_revenue = sum(CAV_revenue))  %>%
#   select(scenario, strategy, wtp_scenario, inflection_year, annual_CAV_take_up, CAV_revenue)

#aggregate_cost <- aggregate_cost[(aggregate_cost$ISD < 5000),]

aggregate_cost$scenario <- factor(aggregate_cost$scenario,
                                  levels = c("high",
                                             "baseline",
                                             "low"))

aggregate_cost$inflection_year <- round(aggregate_cost$inflection_year + 2019,0)

aggregate_cost$inflection_year <- as.factor(aggregate_cost$inflection_year)

penetration_senstivity <- ggplot(aggregate_cost, aes(x=inflection_year, y=CAV_revenue, group=1)) + geom_line() +
  scale_y_continuous(expand = c(0, 0), limits=c(0,0.45)) +
  scale_x_discrete(expand = c(0, 0)) +
  xlab("Adoption Rate Inflection year") +
  ylab("Revenue (Billions GBP)") +
  theme(legend.position = "bottom", axis.text.x = element_text(angle = 45, hjust = 1)) +
  labs(title="Sensitivity of Revenue to Subscription Adoption Rate",
       subtitle="Results reported by scenario and strategy as adoption rate inflection year varies",
       xlab="Adoption Rate Inflection year") +
  facet_grid(scenario~strategy, labeller = labeller(strategy = strategy_labels, scenario = scenario_labels))

### EXPORT TO FOLDER
setwd(path_figures)
tiff('penetration_senstivity.tiff', units="in", width=8, height=9, res=300)
print(penetration_senstivity)
dev.off()


library(ggplot2)
library(data.table)
source('../utils.r')
source('../config.r')

df <- fread('learning_curves.csv')
df[,learning_type := factor(learning_type, levels = c("train", "validation"))]
df[learning_type=="train", learning_type := "Training"]
df[learning_type=="validation", learning_type := "Testing"]
df <- df[learning_type=='Testing']

fig <- ggplot(
  data = df,
  mapping = aes(x = train_sizes, y = mean, color = learning_type,
                fill = learning_type)) +
  facet_wrap(.~target) +
  geom_line(size = 1.4, show.legend = F) +
  geom_ribbon(mapping = aes(ymin = mean -std, ymax = mean + std),
              alpha = 0.2, size = 0.3, show.legend = F) +
  scale_color_manual(values = with(color_cats, c(`sky blue`))) +
  scale_fill_manual(values = with(color_cats, c(`sky blue`))) +
  my_theme +
  coord_cartesian(xlim = c(0, 3100)) +
  scale_x_continuous(limits = c(0, 3000)) +
  scale_y_continuous(breaks = seq(0, 1, 0.1)) +
  labs(x = "# training samples", y = expression("out-of-sample" ~ R^2 ~ "score")) +
  theme(legend.title = element_blank(), legend.position="bottom")

my_ggsave("fig_1-supp-1", fig, width = 11, height = 5)


library(ggplot2)
theme_set(theme_bw(18))
setwd("~/Dropbox/sinking_marbles/sinking-marbles/models/complex_prior/results/")
source("rscripts/helpers.r")

load("data/mp.RData")

mp = read.table("data/parsed_results.tsv", quote="", sep="\t", header=T)
nrow(mp)

summary(mp)
mp$QUDOpt = as.factor(paste(mp$QUD,mp$SpeakerOptimality))
save(mp, file="data/mp.RData")

ggplot(mp, aes(x=NumState,y=PosteriorProbability,shape=as.factor(SpeakerOptimality),color=QUD,group=QUDOpt)) +
  geom_point() +
  geom_line() +
  facet_grid(PriorProbability.100~Alternatives)
ggsave("graphs/full-dists.pdf",height=45)

isall = subset(mp, QUD=="is-all")
howmany = subset(mp, QUD=="how-many")

ggplot(mp, aes(x=PriorProbability.100,y=PosteriorProbability,shape=as.factor(SpeakerOptimality),color=QUD,group=QUDOpt)) +
  geom_point() +
  geom_line() +
  facet_grid(Alternatives~NumState)
ggsave("graphs/byprior.pdf",width=10,height=10)

all = subset(mp, NumState == 3)
ggplot(all, aes(x=PriorProbability.100,y=PosteriorProbability,color=as.factor(SpeakerOptimality))) +
  geom_point() +
  geom_smooth() +
  scale_y_continuous(limits=c(0,1)) +
  facet_grid(QUD~Alternatives)
ggsave("graphs/allprobability-byopt-byqud.pdf",width=12)

head(mp)
nrow(mp)
hmbasic2 = subset(mp, QUD=="how-many" & Alternatives == "basic" & SpeakerOptimality == 2 & NumState == 3)
nrow(hmbasic2)
summary(hmbasic2)
hmbasic2 = droplevels(hmbasic2)
row.names(hmbasic2) = paste(hmbasic2$PriorProbability.0,hmbasic2$PriorProbability.1to50,hmbasic2$PriorProbability.51to99,hmbasic2$PriorProbability.100)
head(hmbasic2)
hmbasic2.cprior = hmbasic2
save(hmbasic2.cprior, file="data/hmbasic2.cprior.RData")


#' Iterator that replicates elements of an iterable object
#'
#' Constructs an iterator that replicates the values of an \code{object}.
#'
#' This function is intended an iterable version of the standard
#' \code{\link[base]{rep}} function. However, as exception, the recycling
#' behavior of \code{\link[base]{rep}} is intentionally not implemented.
#'
#' @export
#' @param object object to return indefinitely.
#' @param times the number of times to repeat each element in \code{object}
#' @param length.out non-negative integer. The desired length of the iterator
#' @param each non-negative integer. Each element is repeated \code{each} times
#' @return iterator that returns \code{object}
#'
#' @examples
#' it <- irep(1:3, 2)
#' unlist(as.list(it)) == rep(1:3, 2)
#'
#' it2 <- irep(1:3, each=2)
#' unlist(as.list(it2)) == rep(1:3, each=2)
#'
#' it3 <- irep(1:3, each=2, length.out=4)
#' as.list(it3)
irep <- function(object, times=1, length.out=NULL, each=NULL) {
  if (!is.null(length.out)) {
    length.out <- as.numeric(length.out)
    if (length(length.out) != 1) {
      stop("'length.out' must be a numeric value of length 1")
    }
  }
  if (!is.null(each)) {
    each <- as.numeric(each)
    if (length(each) != 1) {
      stop("'each' must be a numeric value of length 1")
    }
  }

  it <- icycle(object, times=times)
  if (!is.null(each)) {
    it <- irep_each(it, each=each)
  }

  islice(it, end=length.out)
}

#' @export
#' @rdname irep
irep_len <- function(object, length.out=NULL) {
  irep(object, times=1, length.out=length.out)
}

irep_each <- function(object, each=1) {
  each <- as.integer(each)
  iter_obj <- iterators::iter(object)

  iter_repeat <- irepeat(iterators::nextElem(iter_obj), times=each)

  nextElem <- function() {
    next_elem <- try(iterators::nextElem(iter_repeat), silent=TRUE)
    if (stop_iteration(next_elem)) {
      iter_repeat <<- irepeat(iterators::nextElem(iter_obj), times=each)
      next_elem <- iterators::nextElem(iter_repeat)
    }
    next_elem
  }

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