#Copyright 2016 Lingjiao Chen, Arun Kumar, Jeffrey Naughton, and Jignesh M. Patel, Version 0.8.
#All rights reserved.
#
#Licensed under the Apache License, Version 2.0 (the "License");
#you may not use this file except in compliance with the License.
#You may obtain a copy of the License at
#
#    http://www.apache.org/licenses/LICENSE-2.0
#
#Unless required by applicable law or agreed to in writing, software
#distributed under the License is distributed on an "AS IS" BASIS,
#WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
#See the License for the specific language governing permissions and
#limitations under the License.

##############################################################
print('Logistic Regression on dataset Yelp')

##############################################################
# Load in Packages
print('Loading Packages...')
library("Matrix");
library("matrixStats");
library(data.table);
MyDir = getwd();
SrcDir = paste(getwd(),'/src',sep="");
setwd(SrcDir)
file.sources = list.files(pattern="*.r",recursive=TRUE)
sapply(file.sources,source,.GlobalEnv)
setwd(MyDir)
# Parameter Setting
options(digits = 15)
options(scipen=20)
print('Loading Packages is done')

##############################################################
# Load in Data

##############################################################
print("Reading in data...");
S = matrix(0,0,0);
dS = nrow(S);

FK1dir = './Data/Yelp/MLFK1.csv';
R1dir = './Data/Yelp/MLR1Sparse.txt';
JSet1 = as.matrix(read.table(FK1dir,header=TRUE));
nS = nrow(JSet1);
nR1 = max(JSet1);
FK1 = sparseMatrix(i=c(1:nS),j=JSet1,x=1,dims=c(nS,nR1));
R1S = readMM(file=R1dir)+0;
dR1 = ncol(R1S);

FK2dir = './Data/Yelp/MLFK2.csv';
R2dir = './Data/Yelp/MLR2Sparse.txt';

JSet2 = as.matrix(read.table(FK2dir,header=TRUE));
nS = nrow(JSet2);
nR2 = max(JSet2);
FK2 = sparseMatrix(i=c(1:nS),j=JSet2,x=1,dims=c(nS,nR2));
R2S = readMM(file=R2dir)+0;
dR2 = ncol(R2S);

Ydir = './Data/Yelp/MLY.csv';
Ytest = as.matrix(( fread(Ydir)));
Y = (Ytest > 2.5)+0;
print("Loading data is done");

#############################################################
# Creating Materialized data table and normalized matrix
print("Creating Materialized data table and normalized matrix");
T = cbind(FK1%*%R1S,FK2%*%R2S);
TNM = NormalMatrix(EntTable=list(S),AttTables=list(R1S,R2S),KFKDs=list(FK1,FK2),Sparse=TRUE);
print("Creating Materialized data table and normalized matrix is done");

#############################################################
# Parameter
winit = Matrix(rnorm(ncol(T),2),ncol(T),1,sparse=TRUE);
gamma0 = 0.000001;
Max_Iter = 20;
Result_eps = 1e-6;

#############################################################
# Materilaized Version
print("Materialized Version:");
Material_Time1 = Sys.time();
Material_Result = LogisticRegression(T,Max_Iter, winit, gamma0, Y);
Material_RunTime = Sys.time()-Material_Time1;
print("Materialized Version is done\n");
print("Materialization Runtime:");
print(Material_RunTime);

#############################################################
# Morpheus
print("Morpheus:\n");
Morpheus_Time1 = Sys.time();
Morpheus_Result = LogisticRegression(TNM,Max_Iter, winit, gamma0, Y);
Morpheus_RunTime = Sys.time()-Morpheus_Time1;
print("Morpheus is done\n");
print("Morpheus Runtime: ");
print(Morpheus_RunTime);

if(norm(as.matrix(Material_Result[[1]] - Morpheus_Result[[1]]),'F')<Result_eps*(1+norm(as.matrix(Material_Result[[1]]),'F')) )
{
	print("Pass verification (Both approches return the same ML model).");
}else
{
	print("Fail to pass verification (Both approches return different models).");
}

library("Matrix");
library("matrixStats");
library(data.table);
source('./NMPackageTest/NormalMatrix.r')
# Parameter Setting
options(digits = 15)
options(scipen=20)
IterSet=c(1,5,10,20);
print("LR for real data!")

##############################################################
print("Reading in data...");
S = matrix(0,0,0);

FK1dir = './RealTest/Yelp/MLFK1.csv';
JSet1 = as.matrix(read.table(FK1dir,header=TRUE));
nS = nrow(JSet1);
nR1 = max(JSet1);
FK1 = sparseMatrix(i=c(1:nS),j=JSet1,x=1,dims=c(nS,nR1));
R1S = readMM(file='./RealTest/Yelp/MLR1Sparse.txt')+0;

FK2dir = './RealTest/Yelp/MLFK2.csv';
JSet2 = as.matrix(read.table(FK2dir,header=TRUE));
nS = nrow(JSet2);
nR2 = max(JSet2);
FK2 = sparseMatrix(i=c(1:nS),j=JSet2,x=1,dims=c(nS,nR2));
R2S = readMM(file='./RealTest/Yelp/MLR2Sparse.txt')+0;

Ydir = './RealTest/Yelp/MLY.csv';
Ytest = as.matrix(( fread(Ydir)));
Y = (Ytest > 2.5)+0;
x=Y;
print("Finish Reading!");
#############################################################
T = cbind(FK1%*%R1S,FK2%*%R2S);
TNM = NormalMatrix(EntTable=list(S),AttTables=list(R1S,R2S),KFKDs=list(FK1,FK2),Sparse=TRUE);
print("Finish Creating T and TNM!");
#############################################################

winit = Matrix(rnorm(ncol(T),2),ncol(T),1,sparse=TRUE);

gamma0 = 0.000001;
for( k_MaxIter in 1:length(IterSet))
{
	#Material
	print('LR Material No Disk');
	# Warm up the cache
	gc();
	gc();
	gc();
	gc();
	gc();
	w = winit;
	time1 = Sys.time();
	for( k in 1: 2 )
	{
		w = w - gamma0 * (t(T) %*% (x/(1+exp(T%*%w))) );
	}
	time2 = Sys.time();
	M4 =  difftime(time2, time1, units="secs");
	print(M4)
	print('Finish Warm-up');

	# Material LR
	gc();
	gc();
	gc();
	gc();
	gc();
	w = winit;
	time1 = Sys.time();
	for( k in 1: IterSet[k_MaxIter] )
	{
		w = w - gamma0 * (t(T) %*% (x/(1+exp(T%*%w))) );
	}
	time2 = Sys.time();
	M4 =  difftime(time2, time1, units="secs");
	print(M4)
	# Write the time interval 1
	timeF=as.numeric(M4);
	LogName=paste('./DataLog_RD/LR/Yelp/Log_LR_M_Yelp_iter_',IterSet[k_MaxIter],'_1.txt',sep="");#Log_LR_M_S_10000000x20_R_500000x80_x_100x1_3.txt
	write.table(as.matrix(timeF),LogName, sep=",", row.names = FALSE,  col.names=FALSE);

				gc();
				gc();
				gc();
				gc();
				gc();
				w = winit;
				time1 = Sys.time();
				for( k in 1: IterSet[k_MaxIter] )
				{
					w = w - gamma0 * (t(T) %*% (x/(1+exp(T%*%w))) );
				}
				time2 = Sys.time();
				M4 =  difftime(time2, time1, units="secs");
				print(M4)
				# Write the time interval 1
				timeF=as.numeric(M4);
					LogName=paste('./DataLog_RD/LR/Yelp/Log_LR_M_Yelp_iter_',IterSet[k_MaxIter],'_2.txt',sep="");#Log_LR_M_S_10000000x20_R_500000x80_x_100x1_3.txt
					write.table(as.matrix(timeF),LogName, sep=",", row.names = FALSE,  col.names=FALSE);

				gc();
				gc();
				gc();
				gc();
				gc();
				w = winit;
				time1 = Sys.time();
				for( k in 1: IterSet[k_MaxIter] )
				{
					w = w - gamma0 * (t(T) %*% (x/(1+exp(T%*%w))) );
				}
				time2 = Sys.time();
				M4 =  difftime(time2, time1, units="secs");
				print(M4)
				# Write the time interval 1
				timeF=as.numeric(M4);
				LogName=paste('./DataLog_RD/LR/Yelp/Log_LR_M_Yelp_iter_',IterSet[k_MaxIter],'_3.txt',sep="");#Log_LR_M_S_10000000x20_R_500000x80_x_100x1_3.txt
				write.table(as.matrix(timeF),LogName, sep=",", row.names = FALSE,  col.names=FALSE);

				#Factor
				print('LR Factor No Disk');
				# Warm up the cache
				gc();
				gc();
				gc();
				gc();
				gc();
				w=winit;
				time1 = Sys.time();
				for( k in 1: 2 )
				{
					print(k);
					w = w - gamma0 * (t(TNM) %*% (x/(1+exp(TNM%*%w))) );
				}
				time2 = Sys.time();
				M4 =  difftime(time2, time1, units="secs");
				print(M4)
				print('Finish Warm-up');

				# Factor LR
				gc();
				gc();
				gc();
				gc();
				gc();
				w=winit;
				time1 = Sys.time();
				for( k in 1: IterSet[k_MaxIter] )
				{
					w = w - gamma0 * (t(TNM) %*% (x/(1+exp(TNM%*%w))) );
				}
				time2 = Sys.time();
				M4 =  difftime(time2, time1, units="secs");
				print(M4)
				# Write the time interval 1
				timeF=as.numeric(M4);
				LogName=paste('./DataLog_RD/LR/Yelp/Log_LR_F_Yelp_iter_',IterSet[k_MaxIter],'_1.txt',sep="");#Log_LR_M_S_10000000x20_R_500000x80_x_100x1_3.txt
				write.table(as.matrix(timeF),LogName, sep=",", row.names = FALSE,  col.names=FALSE);

				gc();
				gc();
				gc();
				gc();
				gc();
				w=winit;
				time1 = Sys.time();
				for( k in 1: IterSet[k_MaxIter] )
				{
					w = w - gamma0 * (t(TNM) %*% (x/(1+exp(TNM%*%w))) );
				}
				time2 = Sys.time();
				M4 =  difftime(time2, time1, units="secs");
				print(M4)
				# Write the time interval 1
				timeF=as.numeric(M4);
				LogName=paste('./DataLog_RD/LR/Yelp/Log_LR_F_Yelp_iter_',IterSet[k_MaxIter],'_2.txt',sep="");#Log_LR_M_S_10000000x20_R_500000x80_x_100x1_3.txt
				write.table(as.matrix(timeF),LogName, sep=",", row.names = FALSE,  col.names=FALSE);

				gc();
				gc();
				gc();
				gc();
				gc();
				w=winit;
				time1 = Sys.time();
				for( k in 1: IterSet[k_MaxIter] )
				{
					w = w - gamma0 * (t(TNM) %*% (x/(1+exp(TNM%*%w))) );
				}
				time2 = Sys.time();
				M4 =  difftime(time2, time1, units="secs");
				print(M4)
				# Write the time interval 1
				timeF=as.numeric(M4);
					LogName=paste('./DataLog_RD/LR/Yelp/Log_LR_F_Yelp_iter_',IterSet[k_MaxIter],'_3.txt',sep="");#Log_LR_M_S_10000000x20_R_500000x80_x_100x1_3.txt
					write.table(as.matrix(timeF),LogName, sep=",", row.names = FALSE,  col.names=FALSE);

}


R version 3.3.2 (2016-10-31) -- "Sincere Pumpkin Patch"
Copyright (C) 2016 The R Foundation for Statistical Computing
Platform: x86_64-w64-mingw32/x64 (64-bit)

R is free software and comes with ABSOLUTELY NO WARRANTY.
You are welcome to redistribute it under certain conditions.
Type 'license()' or 'licence()' for distribution details.

R is a collaborative project with many contributors.
Type 'contributors()' for more information and
'citation()' on how to cite R or R packages in publications.

Type 'demo()' for some demos, 'help()' for on-line help, or
'help.start()' for an HTML browser interface to help.
Type 'q()' to quit R.

[Workspace loaded from ~/.RData]

 install.packages("wbstats")
 install.packages("data.table")
 install.packages("googleVis")

 library(wbstats)
 library(data.table)
 library(googleVis)

 Pop_LifeExp_FertRt <- data.table(wb(indicator = c("SP.POP.TOTL", "SP.DYN.LE00.IN", "SP.DYN.TFRT.IN"), startdate = 1960, enddate = 2016))

 Pop_GDPUSD_HeadCnt <- data.table(wb(indicator = c("SP.POP.TOTL", "NY.GDP.MKTP.CD", "SI.POV.2DAY"), startdate = 1960, enddate = 2016))

 Pop_GDPUSD_Sanitation <- data.table(wb(indicator = c("SP.POP.TOTL", "NY.GDP.MKTP.CD", "SH.STA.ACSN"), startdate = 1960, enddate = 2016))

 GDPUSD_Electricity_CO2 <- data.table(wb(indicator = c("NY.GDP.MKTP.CD", "EG.ELC.ACCS.ZS", "EN.ATM.CO2E.KT"), startdate = 1960, enddate = 2016))

 dim(Pop_LifeExp_FertRt)

 dim(Pop_GDPUSD_HeadCnt)

 dim(Pop_GDPUSD_Sanitation)

 dim(GDPUSD_Electricity_CO2)

 str(Pop_LifeExp_FertRt)

 str(Pop_GDPUSD_HeadCnt)

 str(Pop_GDPUSD_Sanitation)

 str(GDPUSD_Electricity_CO2)

 head(Pop_LifeExp_FertRt)

 head(Pop_GDPUSD_HeadCnt)

 head(Pop_GDPUSD_Sanitation)

 head(GDPUSD_Electricity_CO2)

 dim(wb(indicator = "SP.POP.TOTL"))

 dim(wb(indicator = "SP.DYN.LE00.IN"))

 dim(wb(indicator = "SP.DYN.TFRT.IN"))

 dim(wb(indicator = "NY.GDP.MKTP.CD"))

 dim(wb(indicator = "SI.POV.2DAY"))

 dim(wb(indicator = "SH.STA.ACSN"))

 dim(wb(indicator = "EG.ELC.ACCS.ZS"))

 dim(wb(indicator = "EN.ATM.CO2E.KT"))

 Countries <- data.table(wbcountries())

 head(Countries)

 setkey(Pop_LifeExp_FertRt, iso2c)

 setkey(Pop_GDPUSD_HeadCnt, iso2c)

 setkey(Pop_GDPUSD_Sanitation, iso2c)

 setkey(GDPUSD_Electricity_CO2, iso2c)

 setkey(Countries, iso2c)

 head(setkey(Countries, iso2c))

 Pop_LifeExp_FertRt <- Countries[Pop_LifeExp_FertRt][ ! region %in% "Aggregates"]

 head(Pop_LifeExp_FertRt)

 Pop_GDPUSD_HeadCnt <- Countries[Pop_GDPUSD_HeadCnt][ ! region %in% "Aggregates"]

 Pop_GDPUSD_Sanitation <- Countries[Pop_GDPUSD_Sanitation][ ! region %in% "Aggregates"]

 GDPUSD_Electricity_CO2 <- Countries[GDPUSD_Electricity_CO2][ ! region %in% "Aggregates"]

 wPop_LifeExp_FertRt <- reshape(Pop_LifeExp_FertRt[, list(country, region, date, value, indicator)], v.names = "value", idvar=c("date", "country", "region"), timevar="indicator", direction = "wide")

 wPop_GDPUSD_HeadCnt <- reshape(Pop_GDPUSD_HeadCnt[, list(country, region, date, value, indicator)], v.names = "value", idvar=c("date", "country", "region"), timevar="indicator", direction = "wide")

 wPop_GDPUSD_Sanitation <- reshape(Pop_GDPUSD_Sanitation[, list(country, region, date, value, indicator)], v.names = "value", idvar=c("date", "country", "region"), timevar="indicator", direction = "wide")

 wGDPUSD_Electricity_CO2 <- reshape(GDPUSD_Electricity_CO2[, list(country, region, date, value, indicator)], v.names = "value", idvar=c("date", "country", "region"), timevar="indicator", direction = "wide")

 wPop_LifeExp_FertRt

 wGDPUSD_Electricity_CO2

 wPop_LifeExp_FertRt[, date := as.integer(date)]

 wPop_GDPUSD_HeadCnt[, date := as.integer(date)]

 wPop_GDPUSD_Sanitation[, date := as.integer(date)]

 wGDPUSD_Electricity_CO2[, date := as.integer(date)]

 setnames(wPop_LifeExp_FertRt, names(wPop_LifeExp_FertRt), c("Country", "Region", "Year", "Population", "Fertility", "LifeExpectancy"))

 setnames(wPop_GDPUSD_HeadCnt, names(wPop_GDPUSD_HeadCnt), c("Country", "Region", "Year", "Population", "GDPUSD", "PovertyHead"))

 setnames(wPop_GDPUSD_Sanitation, names(wPop_GDPUSD_Sanitation), c("Country", "Region", "Year", "Population", "GDPUSD", "SanitationAccess"))

 setnames(wGDPUSD_Electricity_CO2, names(wGDPUSD_Electricity_CO2), c("Country", "Region", "Year", "GDPUSD", "ElectricityConsumption", "CO2Emissions"))

 pltPop_LifeExp_FertRt <- gvisMotionChart(wPop_LifeExp_FertRt, idvar = "Country", timevar = "Year", xvar = "LifeExpectancy", yvar = "Fertility", sizevar = "Population", colorvar = "Region")

 plot(pltPop_LifeExp_FertRt)

 pltPop_GDPUSD_HeadCnt <- gvisMotionChart(wPop_GDPUSD_HeadCnt, idvar = "Country", timevar = "Year", xvar = "GDPUSD", yvar = "PovertyHead", sizevar = "Population", colorvar = "Region")

 plot(pltPop_GDPUSD_HeadCnt)

 pltPop_GDPUSD_Sanitation <- gvisMotionChart(wPop_GDPUSD_Sanitation, idvar = "Country", timevar = "Year", xvar = "GDPUSD", yvar = "SanitationAccess", sizevar = "Population", colorvar = "Region")

 plot(pltPop_GDPUSD_Sanitation)

 pltGDPUSD_Electricity_CO2 <- gvisMotionChart(wGDPUSD_Electricity_CO2, idvar = "Country", timevar = "Year", xvar = "GDPUSD", yvar = "ElectricityAccess", sizevar = "CO2Emissions", colorvar = "Region")

 plot(pltGDPUSD_Electricity_CO2)

Chapter 12/Case Study 1 - World Bank data Analysis.r


### Load Packages ###

if (!require("pacman")) install.packages("pacman")
pacman::p_load(RMySQL,tidyverse,wCorr)

### Load and prepare Savant Data

savant_15a <- read_csv("savant_data_15a.csv") # Download from Savant
savant_16a <- read_csv("savant_data_16a.csv") # Download from Savant
savant_17a <- read_csv("savant_data_17a.csv") # Download from Savant

savant_15a[,4:31] <- apply(savant_15a[,4:31], 2, as.numeric)
savant_16a[,4:31] <- apply(savant_16a[,4:31], 2, as.numeric)
savant_17a[,4:31] <- apply(savant_17a[,4:31], 2, as.numeric)

### Load and prepare BP Data

BP_data <- read_csv("BP.data.csv")
BP_data$X1 <- NULL
BP_data$X1_1 <- NULL

BP_data_15 <- dplyr::filter(BP_data, year==2015)
BP_data_16 <- dplyr::filter(BP_data, year==2016)
BP_data_17 <- dplyr::filter(BP_data, year==2017)

### Combine data sets

df.2015 <- dplyr::inner_join(savant_15a, BP_data_15, by=c("player_id" = "mlbcode"))
df.2016 <- dplyr::inner_join(savant_16a, BP_data_16, by=c("player_id" = "mlbcode"))
df.2017 <- dplyr::inner_join(savant_17a, BP_data_17, by=c("player_id" = "mlbcode"))

df_15_16 <- dplyr::inner_join(df.2015, df.2016, by=c("player_id", "player_name"))
df_16_17 <- dplyr::inner_join(df.2016, df.2017, by=c("player_id", "player_name"))

sav.comp.y1 <- dplyr::bind_rows(df_15_16, df_16_17) %>%
  dplyr::select(player_id, player_name,
                ba.x, woba.x, xwoba.x, xba.x, hits.x, abs.x,
                ba.y, woba.y, xwoba.y, xba.y, hits.y, abs.y,
                FIP.x, DRA.x, PA.x,
                FIP.y, DRA.y, PA.y) %>%
  dplyr::mutate(hits_hm = 2 / (1/hits.x + 1/hits.y),
                abs_hm = 2 / (1/abs.x + 1/abs.y),
                PA_hm = 2 / (1/PA.x + 1/PA.y)
  )

sav.comp.y0 <- dplyr::bind_rows(df.2015, df.2016, df.2017) %>%
  dplyr::select(player_id, player_name,
                ba, woba, xwoba, xba, hits, abs,
                ba, woba, xwoba, xba, hits, abs,
                FIP, DRA, PA,
                FIP, DRA, PA
  )

sav.comp.y1 <- na.omit(sav.comp.y1)
sav.comp.y0 <- na.omit(sav.comp.y0)

#### metric compare

#### resampled metrics (same year)

xba.ba <- vector()
FIP.ba <- vector()
DRA.ba <- vector()

xwoba.woba <- vector()
FIP.woba <- vector()
DRA.woba <- vector()

set.seed(2018)

# Bayesian bootstrap and summary

for (i in 1:100000){

samp.weights.orig <- matrix( rexp(nrow(sav.comp.y0), 1), ncol = nrow(sav.comp.y0), byrow = TRUE)
samp.weights.norm <- samp.weights.orig / rowSums(samp.weights.orig)

test.1.samp <- dplyr::sample_n(as.data.frame(sav.comp.y0),
                               size=nrow(sav.comp.y0),
                               weight = samp.weights.norm,
                               replace=TRUE)

xba.ba[i] <- weightedCorr(test.1.samp$xba, test.1.samp$ba, test.1.samp$abs, method='Spearman')
FIP.ba[i] <- weightedCorr(test.1.samp$FIP, test.1.samp$ba, test.1.samp$abs, method='Spearman')
DRA.ba[i] <- weightedCorr(test.1.samp$DRA, test.1.samp$ba, test.1.samp$abs, method='Spearman')

xwoba.woba[i] <- weightedCorr(test.1.samp$xwoba, test.1.samp$woba, test.1.samp$abs, method='Spearman')
FIP.woba[i] <- weightedCorr(test.1.samp$FIP, test.1.samp$woba, test.1.samp$abs, method='Spearman')
DRA.woba[i] <- weightedCorr(test.1.samp$DRA, test.1.samp$woba, test.1.samp$abs, method='Spearman')

}

print(data_frame("ba.ba.mean" = mean(xba.ba), "ba.ba.sd" = sd(xba.ba)))
print(data_frame("FIP.ba.mean" = mean(FIP.ba), "FIP.ba.sd" = sd(FIP.ba)))
print(data_frame("DRA.ba.mean" = mean(DRA.ba), "DRA.ba.sd" = sd(DRA.ba)))

print(data_frame("xwoba.woba.mean" = mean(xwoba.woba), "xwoba.woba.sd" = sd(xwoba.woba)))
print(data_frame("FIP.woba.mean" = mean(FIP.woba), "FIP.woba.sd" = sd(FIP.woba)))
print(data_frame("DRA.woba.mean" = mean(DRA.woba), "DRA.woba.sd" = sd(DRA.woba)))

#### resampled metrics (year + 1)

xba.ba.x.y <- vector()
ba.ba.x.y <- vector()
FIP.ba.x.y <- vector()
DRA.ba.x.y <- vector()

xwoba.woba.x.y <- vector()
woba.woba.x.y <- vector()
FIP.woba.x.y <- vector()
DRA.woba.x.y <- vector()

xba.xba.x.y <- vector()
ba.ba.x.y <- vector()
xwoba.xwoba.x.y <- vector()
woba.woba.x.y <- vector()
FIP.FIP.x.y  <- vector()
DRA.DRA.x.y <- vector()

set.seed(2018)

# Bayesian bootstrap and summary

for (i in 1:100000){

  samp.weights.1 <- matrix( rexp(nrow(sav.comp.y1), 1), ncol = nrow(sav.comp.y1), byrow = TRUE)
  samp.weights <- samp.weights.1 / rowSums(samp.weights.1)

  test.1.samp <- dplyr::sample_n(as.data.frame(sav.comp.y1),
                                 size=nrow(sav.comp.y1),
                                 weight = samp.weights,
                                 replace=TRUE)

  ### xBA predictive versus BA, FIP, and DRA

xba.ba.x.y[i] <-   weightedCorr(test.1.samp$xba.x, test.1.samp$ba.y, test.1.samp$abs_hm, method='Spearman')
ba.ba.x.y[i] <-    weightedCorr(test.1.samp$ba.x, test.1.samp$ba.y, test.1.samp$abs_hm, method='Spearman')
FIP.ba.x.y[i] <-   weightedCorr(test.1.samp$FIP.x, test.1.samp$ba.y, test.1.samp$abs_hm, method='Spearman')
DRA.ba.x.y[i] <-   weightedCorr(test.1.samp$DRA.x, test.1.samp$ba.y, test.1.samp$abs_hm, method='Spearman')

  ### xwOBA predictive versus BA, FIP, and DRA

xwoba.woba.x.y[i] <-    weightedCorr(test.1.samp$xwoba.x, test.1.samp$woba.y, test.1.samp$abs_hm, method='Spearman')
woba.woba.x.y[i] <-     weightedCorr(test.1.samp$woba.x, test.1.samp$woba.y, test.1.samp$abs_hm, method='Spearman')
FIP.woba.x.y[i] <-      weightedCorr(test.1.samp$FIP.x, test.1.samp$woba.y, test.1.samp$abs_hm, method='Spearman')
DRA.woba.x.y[i] <-      weightedCorr(test.1.samp$DRA.x, test.1.samp$woba.y, test.1.samp$abs_hm, method='Spearman')

### xBA / xwOBA reliability versus BA, FIP, and DRA

xba.xba.x.y[i] <-         weightedCorr(test.1.samp$xba.x, test.1.samp$xba.y, test.1.samp$abs_hm, method='Spearman')
ba.ba.x.y[i] <-           weightedCorr(test.1.samp$ba.x, test.1.samp$ba.y, test.1.samp$abs_hm, method='Spearman')
xwoba.xwoba.x.y[i] <-     weightedCorr(test.1.samp$xwoba.x, test.1.samp$xwoba.y, test.1.samp$abs_hm, method='Spearman')
woba.woba.x.y[i] <-       weightedCorr(test.1.samp$woba.x, test.1.samp$woba.y, test.1.samp$abs_hm, method='Spearman')
FIP.FIP.x.y[i] <-         weightedCorr(test.1.samp$FIP.x, test.1.samp$FIP.y, test.1.samp$abs_hm, method='Spearman')
DRA.DRA.x.y[i] <-         weightedCorr(test.1.samp$DRA.x, test.1.samp$DRA.y, test.1.samp$abs_hm, method='Spearman')

}

print(data.frame("xba.ba.x.y.mean" = mean(xba.ba.x.y), "xba.ba.x.y.sd" = sd(xba.ba.x.y)))
print(data.frame("ba.ba.x.y.mean" = mean(ba.ba.x.y), "ba.ba.x.y.sd" = sd(ba.ba.x.y)))
print(data.frame("FIP.ba.x.y.mean" = mean(FIP.ba.x.y), "FIP.ba.x.y.sd" = sd(FIP.ba.x.y)))
print(data.frame("DRA.ba.x.y.mean" = mean(DRA.ba.x.y), "DRA.ba.x.y.sd" = sd(DRA.ba.x.y)))

print(data.frame("xwoba.woba.x.y.mean" = mean(xwoba.woba.x.y), "xwoba.woba.x.y.sd" = sd(xwoba.woba.x.y)))
print(data.frame("woba.woba.x.y.mean" = mean(woba.woba.x.y), "woba.woba.x.y.sd" = sd(woba.woba.x.y)))
print(data.frame("FIP.woba.x.y.mean" = mean(FIP.woba.x.y), "FIP.woba.x.y.sd" = sd(FIP.woba.x.y)))
print(data.frame("DRA.woba.x.y.mean" = mean(DRA.woba.x.y), "DRA.woba.x.y.sd" = sd(DRA.woba.x.y)))

print(data.frame("xba.xba.x.y.mean" = mean(xba.xba.x.y), "xba.xba.x.y.sd" = sd(xba.xba.x.y)))
print(data.frame("ba.ba.x.y.mean" = mean(ba.ba.x.y), "ba.ba.x.y.sd" = sd(ba.ba.x.y)))
print(data.frame("xwoba.xwoba.x.y.mean" = mean(xwoba.xwoba.x.y), "xwoba.xwoba.x.y.sd" = sd(xwoba.xwoba.x.y)))
print(data.frame("woba.woba.x.y.mean" = mean(woba.woba.x.y), "woba.woba.x.y.sd" = sd(woba.woba.x.y)))
print(data.frame("FIP.FIP.x.y.mean" = mean(FIP.FIP.x.y), "FIP.FIP.x.y.sd" = sd(FIP.FIP.x.y)))
print(data.frame("DRA.DRA.x.y.mean" = mean(DRA.DRA.x.y), "DRA.DRA.x.y.sd" = sd(DRA.DRA.x.y)))

print(data.frame("xba.ba.x.y.mean" = mean(xba.ba.x.y), "xba.ba.x.y.sd" = sd(xba.ba.x.y)))
print(data.frame("ba.ba.x.y.mean" = mean(ba.ba.x.y), "ba.ba.x.y.sd" = sd(ba.ba.x.y)))
print(data.frame("FIP.ba.x.y.mean" = mean(FIP.ba.x.y), "FIP.ba.x.y.sd" = sd(FIP.ba.x.y)))
print(data.frame("DRA.ba.x.y.mean" = mean(DRA.ba.x.y), "DRA.ba.x.y.sd" = sd(DRA.ba.x.y)))


##
## Analyse social relations models
##
source("init if necessary.r")

library(ggplot2)
library(bayesplot)

# import social relations models
load(file.path(models.dir, "social relations models.RData"))
load(file.path(models.dir, "social relations models - comparison.RData"))

flog.info("Analysing social relations models")

best_srrm = fit_srrm2  # the best model, based on goodness of fit and performance metrics

################################################################################
## Coefficients for the best-fitting model
##
log_odds = best_srrm$BETA
log_odds_sum = t( apply(log_odds, 2, function(x) quantile(x, c(0.5, 0.025, 0.975))) )

write.csv(log_odds_sum, file=file.path(results.dir, "social relations model - coefficients table.csv"), row.names=T)

####################################################################
## Posterior predictions for best model
##
n.samples = 50
r_seq = seq(0, 0.5, length.out = n.samples)
d.pred = expand.grid(r=r_seq, siida=0:1, gift=0:1)

# calculate model predictions
pred.raw = sapply(1:nrow(d.pred), function(i) p.link_srrm2(best_srrm, d.pred$r[i], d.pred$siida[i], d.pred$gift[i]))
pred.p = apply(pred.raw, 2, mean)
pred.p.PI = apply(pred.raw, 2, quantile, c(0.025, 0.975))  # apply(pred.raw, 2, PI)

d.pred$pred.p = pred.p
d.pred$lwr = pred.p.PI[1,]
d.pred$upr = pred.p.PI[2,]

##
## plot predictions, split by siida co-membership and whether or not ego was named by alter in their cooperation network
##
d.pred$gift = factor(d.pred$gift)
levels(d.pred$gift) = c("No gift given", "Gift given to alter")

plt.srm = ggplot(d.pred, aes(x=r, y=pred.p)) +
  geom_line(aes(colour=factor(siida)), size=1.5) +
  geom_ribbon(aes(ymin=lwr, ymax=upr, fill=factor(siida)), alpha=0.3) +

  facet_grid(~gift) +  #, labeller="label_both") +

  scale_colour_manual(values = saami_blue_green) +
  scale_fill_manual(values = saami_blue_green) +

  scale_x_log10(breaks=c(0.0001, 0.015, 0.031, 0.063, 0.125, 0.25, 0.5)) +  # plot relatedness on log scale with breaks at familiar points
  #c(0.0001, 0.0039, 0.0078, 0.015, 0.031, 0.063, 0.125, 0.25, 0.5)

  xlab("Coefficient of relatedness") +
  ylab("Probability of naming alter in cooperation network") +
  ylim(c(0,1)) +
  common_theme

plt.srm
ggsave(filename=file.path(plots.dir, "social relations model predictions.png"), plot=plt.srm, width=300, height=150, units="mm")
ggsave(filename=file.path(plots.dir, "social relations model predictions.pdf"), plot=plt.srm, width=300, height=150, units="mm")

# save a version for A0 poster
# plt.srm + poster_theme
# ggsave(filename=file.path(plots.dir, "social relations model predictions - poster.png"), width=475, height=250, units="mm")

#######################################################################
## Calculate and plot variance partition coefficients and reciprocity correlations
##
vc = best_srrm$VC

sigma2_g = vc[,1]  # within-row (giver) variance
sigma2_r = vc[,3]  # within-column (receiver) variance
sigma_gr = vc[,2]  # giver-receiver covariance

rho_gr = sigma_gr / sqrt(sigma2_g * sigma2_r)  # giver-receiver correlation

rho_dd = vc[,4]    # within-dyad correlation
sigma2_d = vc[,5]  # between-dyad variance

##
## reciprocity
##
# plot prediction intervals of correlations directly from the posteriors
rho = data.frame(Generalised = rho_gr, Dyadic = rho_dd)

# plot prediction intervals for reciprocity correlations
# this will go in the top-left corner of the predictions plot
options(bayesplot.base_size = 12, bayesplot.base_family = "sans")
color_scheme_set("yellow")

plt.srm.recip = mcmc_intervals(rho, prob=0.8, prob_outer=0.95) + labs(x = "Reciprocity correlation") + common_theme

##
## partitioning variance
##
vpc_g = (sigma2_g / (sigma2_g + sigma2_r + sigma2_d))  # giver VPC
vpc_r = (sigma2_r / (sigma2_g + sigma2_r + sigma2_d))  # receiver VPC
vpc_d = (sigma2_d / (sigma2_g + sigma2_r + sigma2_d))  # relationship VPC

# make a violin plot of the VPCs
vpc = data.frame(vpc_g, vpc_r, vpc_d) %>%
  gather(VPC, value, vpc_g:vpc_d)
vpc$VPC = factor(vpc$VPC, levels=c("vpc_d", "vpc_r", "vpc_g"))
levels(vpc$VPC) = c("Dyadic VPC", "Receiver VPC", "Giver VPC")

plt.srm.vpc = ggplot(vpc, aes(x=VPC, y=value)) +
  geom_violin(fill=saami_yellow, colour=saami_yellow_dark, alpha=0.75, draw_quantiles = c(0.025, 0.5, 0.975)) +
  xlab("") +
  ylab("Variance partition coefficient") +
  coord_flip() +
  common_theme

##
## make figure for paper containing reciprocity correlations + VPCs
##
plt_a = plt.srm.recip + ggtitle("a")
plt_b = plt.srm.vpc   + ggtitle("b")

png(file.path(plots.dir, "social relations model - reciprocity and vpc.png"), height=12.5, width=25, units="cm", res=300)
gridExtra::grid.arrange(plt_a, plt_b, ncol=2)
dev.off()

pdf(file.path(plots.dir, "social relations model - reciprocity and vpc.pdf"), height=5, width=10)
gridExtra::grid.arrange(plt_a, plt_b, ncol=2)
dev.off()

##
## save plots for poster
##
# plt.srm.recip + poster_theme
# ggsave(filename=file.path(plots.dir, "social relations model - poster - reciprocity correlations.png"), plot=recip, width=175, height=125, units="mm")
# plt.srm.vpc + poster_theme
# ggsave(filename=file.path(plots.dir, "social relations model - poster - vpc.png"), width=175, height=125, units="mm")  # for poster

flog.info("Finished analysing social relations models")


library(plotly)
library(htmlwidgets)

library(sf)
sf_use_s2(FALSE)

Sys.setlocale("LC_TIME", "hr_HR.UTF-8")

hr <- st_read(dsn = "data/Official_Croatia_Boundaries/CROATIA_HR_Županije_ADMIN1.shp")

hr <- hr[order(hr$ZUP_IME),]
hr$Zupanija <- hr$ZUP_IME

hr$ZUP_IME

Regija <- rep(NA, nrow(hr))

Regija[c(1, 18, 12, 2, 11, 19, 6, 15)] <- 'Panonska Hrvatska'
Regija[c(13, 9, 20, 14, 16, 5, 3)] <- 'Jadranska Hrvatska'
Regija[c(4)] <- 'Grad Zagreb'
Regija[c(10, 17, 7, 8, 21)] <- 'Sjeverna Hrvatska'

hr <- cbind(hr, Regija)

load('data/latest/percentage_change.Rda')
load('data/latest/sum_7_df.Rda')
load('data/latest/sum_14_df.Rda')

# get last_date_
load('data/latest/last_date_.Rda')
load('data/latest/last_date.Rda')

hr$ZUP_IME

percentage_change_reordered <- t(percentage_change[nrow(percentage_change), c(1:21)])
colnames(percentage_change_reordered)[1] <- 'Tjedna razlika'

population_by_age <- read.csv(file = 'data/cro_population_by_age.csv')
population_per_county <- population_by_age[nrow(population_by_age), ]

hr$ZUP_IME

# broj stanovnika po zupanijama preuzet s https://www.dzs.hr/
population_reordered <- as.numeric(population_per_county[1, c(2:22)])

population_reordered

sum_7_df[nrow(sum_7_df),c(1:21)]

sum_7_reordered <- t(sum_7_df[nrow(sum_7_df), c(1:21)])
sum_7_reordered_norm <- (sum_7_reordered / population_reordered) * 100000

colnames(sum_7_reordered)[1] <- 'Ukupno_7d'
colnames(sum_7_reordered_norm)[1] <- 'Ukupno_7d_norm'

sum_14_reordered <- t(sum_14_df[nrow(sum_14_df), c(1:21)])
sum_14_reordered_norm <- (sum_14_reordered / population_reordered) * 100000

colnames(sum_14_reordered)[1] <- 'Ukupno_14d'
colnames(sum_14_reordered_norm)[1] <- 'Ukupno_14d_norm'

hr <-cbind(hr, percentage_change_reordered, sum_7_reordered_norm, sum_14_reordered_norm, sum_7_reordered, sum_14_reordered, population_reordered)
colnames(hr)
colnames(hr)[10] <- 'Populacija'

print(colnames(hr))

Ukupno_regija <- hr %>% group_by(Regija) %>% summarise(Ukupno_7d = sum(Ukupno_7d),
                                                       Ukupno_14d = sum(Ukupno_14d),
                                                       Populacija_regija = sum(Populacija))

Ukupno_regija

Ukupno_regija$Ukupno_7d_norm_regija <- Ukupno_regija$Ukupno_7d / Ukupno_regija$Populacija_regija * 100000
Ukupno_regija$Ukupno_14d_norm_regija <- Ukupno_regija$Ukupno_14d / Ukupno_regija$Populacija_regija  * 100000

Ukupno_regija

my_breaks <-c(0, 100, 200, 400, 800, 1600)
my_labels <-c('0', '100', '200', '400', '800', '1600+')

hr_region_map14 <- ggplot(Ukupno_regija, aes(text = paste("Regija: ", Regija, "
", "Ukupno u zadnjih 14 dana na 100k stanovnika: ", round(Ukupno_14d_norm_regija, digits= 2), sep=""))) +
  ggtitle(paste("COVID 19 u Hrvatskoj: Ukupan broj zaraženih u zadnjih 14 dana na 100000 stanovnika po regijama (", last_date, ")", sep="")) +
  geom_sf(aes_string(fill = 'Ukupno_14d_norm_regija')) +
  #scale_fill_distiller(palette = "RdYlGn", limits = c(0,  200), oob = scales::squish, name='Broj slučajeva') +
  scale_fill_distiller(palette="Spectral", oob = scales::squish, name='Ukupno\nu 14 dana\nna 100000\nstanovnika', limits = c(0, 1600), labels=my_labels, breaks=my_breaks) +

  geom_sf_text(aes(label=round(Ukupno_14d_norm_regija, digits= 0)), fontface="bold", size=5, color="black") +
  theme(legend.position = "bottom") +
  theme_void() +
  labs(caption = paste('Boje prikazuju ukupan broj slučajeva zadnjih 14 dana po regijama, normalizirano na 100000 stanovnika.\n\nGenerirano: ', format(Sys.time() + as.difftime(1, units="hours"), '%d.%m.%Y. %H:%M:%S h'), ', izvor podataka: koronavirus.hr, dzs.hr (popis stanovništva 2021.), autor: Petar Palašek, ppalasek.github.io', sep='')) +
  theme(plot.caption = element_text(hjust = 0))

hr_region_map14

ggsave(paste('img/', last_date_, '_map_14_day_per_100k_region.png', sep = ''), plot = hr_region_map14, dpi=300, width=309.80, height=215.90, units="mm")

hr_map <- ggplot(hr, aes(text = paste("Županija: ", Zupanija, "
", "Tjedna razlika: ", round(Tjedna.razlika, digits= 2), "%", "
",
                                      "Ukupno u zadnjih 7 dana: ", Ukupno_7d, "
",
                                      "Ukupno u zadnjih 14 dana: ", Ukupno_14d, "
",
                                      "Ukupno u zadnjih 7 dana na 100k: ", round(Ukupno_7d_norm, digits= 2), "
",
                                      "Ukupno u zadnjih 14 dana na 100k: ", round(Ukupno_14d_norm, digits= 2),  "
",
                                      "Populacija: ", Populacija,  "
",
                                      sep=""))) +
  ggtitle(paste("COVID 19 u Hrvatskoj: Pregled tjedne promjene broja zaraženih po županijama (", last_date, ")", sep="")) +
  geom_sf(aes_string(fill = 'Tjedna.razlika')) +
  scale_fill_distiller(palette = "RdYlGn", limits = c(-75, 75), oob = scales::oob_squish_any, name='Promjena u postocima') +
  geom_sf_text(aes(label=paste(sprintf("%+d", round(Tjedna.razlika, digits= 0)), "%", sep="")), fontface="bold", size=5, color="black") +
  theme(legend.position = "bottom") +
  theme_void() +
  labs(caption = paste('Boje prikazuju promjenu prosječnog broja slučajeva zadnjih tjedan dana u usporedbi s prosjekom broja slučajeva prethodnog tjedna.\n\nGenerirano: ', format(Sys.time() + as.difftime(1, units="hours"), '%d.%m.%Y. %H:%M:%S h'), ', izvor podataka: koronavirus.hr, dzs.hr (popis stanovništva 2021.), autor: Petar Palašek, ppalasek.github.io', sep='')) +
  theme(plot.caption = element_text(hjust = 0))

hr_map

ggsave(paste('img/', last_date_, '_map.png', sep = ''), plot = hr_map, dpi=300, width=309.80, height=215.90, units="mm")

my_breaks <-c(0, 50, 100, 200, 400, 800)
my_labels <-c('0', '50', '100', '200', '400', '800+')

hr_map7 <- ggplot(hr, aes(text = paste("Županija: ", Zupanija, "
", "Ukupno u zadnjih 7 dana na 100k stanovnika: ", round(Ukupno_7d_norm, digits= 2), sep=""))) +
  ggtitle(paste("COVID 19 u Hrvatskoj: Ukupan broj zaraženih u zadnjih 7 dana na 100000 stanovnika (", last_date, ")", sep="")) +
  geom_sf(aes_string(fill = 'Ukupno_7d_norm')) +
  #scale_fill_distiller(palette = "RdYlGn", limits = c(0,  1600), oob = scales::squish, name='Broj slučajeva') +
  scale_fill_distiller(palette="Spectral", oob = scales::squish, name='Ukupno\nu 7 dana\nna 100000\nstanovnika', limits = c(0, 800), labels=my_labels, breaks=my_breaks) +

  geom_sf_text(aes(label=round(Ukupno_7d_norm, digits= 0)), fontface="bold", size=5, color="black") +
  theme(legend.position = "bottom") +
  theme_void() +
  labs(caption = paste('Boje prikazuju ukupan broj slučajeva zadnjih 7 dana u svakoj županiji, normalizirano na 100000 stanovnika.\n\nGenerirano: ', format(Sys.time() + as.difftime(1, units="hours"), '%d.%m.%Y. %H:%M:%S h'), ', izvor podataka: koronavirus.hr, dzs.hr (popis stanovništva 2021.), autor: Petar Palašek, ppalasek.github.io', sep='')) +
  theme(plot.caption = element_text(hjust = 0))

hr_map7

ggsave(paste('img/', last_date_, '_map_7_day_per_100k.png', sep = ''), plot = hr_map7, dpi=300, width=309.80, height=215.90, units="mm")

my_breaks <-c(0, 100, 200, 400, 800, 1600)
my_labels <-c('0', '100', '200', '400', '800', '1600+')

hr_map14 <- ggplot(hr, aes(text = paste("Županija: ", Zupanija, "
", "Ukupno u zadnjih 14 dana na 100k stanovnika: ", round(Ukupno_14d_norm, digits= 2), sep=""))) +
  ggtitle(paste("COVID 19 u Hrvatskoj: Ukupan broj zaraženih u zadnjih 14 dana na 100000 stanovnika (", last_date, ")", sep="")) +
  geom_sf(aes_string(fill = 'Ukupno_14d_norm')) +
  # scale_fill_distiller(palette = "RdYlGn", limits = c(0,  3200), oob = scales::squish, name='Broj slučajeva') +
  scale_fill_distiller(palette="Spectral", oob = scales::squish, name='Ukupno\nu 14 dana\nna 100000\nstanovnika', limits = c(0, 1600), labels=my_labels, breaks=my_breaks) +

  geom_sf_text(aes(label=round(Ukupno_14d_norm, digits= 0)), fontface="bold", size=5, color="black") +
  theme(legend.position = "bottom") +
  theme_void() +
  labs(caption = paste('Boje prikazuju ukupan broj slučajeva zadnjih 14 dana u svakoj županiji, normalizirano na 100000 stanovnika.\n\nGenerirano: ', format(Sys.time() + as.difftime(1, units="hours"), '%d.%m.%Y. %H:%M:%S h'), ', izvor podataka: koronavirus.hr, dzs.hr (popis stanovništva 2021.), autor: Petar Palašek, ppalasek.github.io', sep='')) +
  theme(plot.caption = element_text(hjust = 0))

hr_map14

ggsave(paste('img/', last_date_, '_map_14_day_per_100k.png', sep = ''), plot = hr_map14, dpi=300, width=309.80, height=215.90, units="mm")

hr_map <- ggplotly(hr_map, tooltip = c("text"))

hr_map

saveWidget(hr_map, file = "html/index_map.html", title = paste("COVID 19 u Hrvatskoj: Pregled broja zaraženih po županijama (", last_date, ")", sep=""))


#!/usr/bin/env Rscript

# Run with 'Rscript data_cleaning_and_exploration.r'

## Data Cleaning and Standardization:
##   1. Inital Exploration
##     a. Data set dimensions (number of rows and columns)
##     b. Summary of variables
##     c. Identify potential problems
##     d. Quick visualization
##       1. Why visualize? Look at Anscombe’s quartet for an example.
##       2. Observe outlying values
##       3. Observe and understand the shape of the distributions
##   2. Fixing errors
##     a. Remove irrelevant columns or rows
##     b. Identify and deal with missing values
##     c. Look for and remove incorrect data (impossible values, duplicates, typos, and extra spaces)
##     d. Errors vs. Artifacts
##   3. Standardize values
##      a. Scaling (changing the range of data)
##      b. Normalization
##   4. Dimensionality reduction: Can you get rid of any columns?
##      a. High ratio of missing values (based on a determined threshold)
##      b. High correlation with other variable(s)
##      c. Various methods discussed here
##   5. Repeat visualization
##   6. Write a cleaned data frame to a .csv file
##   7. Convert your df to a tibble
##
## Data Exploration:
##   1. Descriptive Stats
##   2. Exploratory Data Analysis (EDA)
##   3. Visual presentation

# Load the dataset
# Identifies missing data more accurately. Why is this?
library(readr)
companies <- read_csv("/Users/mbc400/Box Sync/GitHub/data-cleaning-with-r/datasets/company_dataset.csv")

##
## 1. Initial Exploration
##   a. Summary of variables
##   b. Data set dimensions (number of rows and columns)
##   c. Identify potential problems
##   d. Quick visualization
##     1. Why visualize? Look at Anscombe’s quartet for an example.
##     2. Observe outlying values
##     3. Observe and understand the shape of the distributions

# Look at the data frame
View(companies)

# Summarize the data
summary(companies)

# Look at the data structure
str(companies)

# Type of data structure in R
class(companies)

# Data set dimensions
dim(companies)

# Quick Visual Exploration
#
# This helps us get an idea about the distribution of values for different variables and lets us know if we have any outliers
hist(companies$Gross_Income_2013)
boxplot(companies$Num_widgets)

## 2. Fixing Errors
##
##   a. Remove irrelevant columns or rows
##

# Add some content here

## 2. Fixing Errors
##
##   b. Identify and deal with missing values
##
##      IMPORTANT NOTE: Verify that all missing values are actually missing. If you notice more missing values
##                      than expected, make sure there wasn't a problem at the data import step.

###
# Count the number of missing values
###

# Checking for missing values; returns a logical data frame with TRUE if value is missing, FALSE otherwise
is.na(companies)

# Returns the number of missing values in each column
sapply(companies, function(x) sum(is.na(x)))

# Returns just columns with missing values
missing_vals <- sapply(companies, function(x) sum(is.na(x)))
missing_vals[missing_vals > 0]

# List all records that have any missing values
companies[!complete.cases(companies),]

###
# Decide what to do with missing values
###

# Ignore
#
# If you choose to ignore missing values remember to use `na.rm = TRUE` for aggregate functions or you will
# get `NA` as a result:
mean(companies$Num_widgets, na.rm=TRUE)

# Exclude
#
# Return all rows with missing values in at least one column
companies[!complete.cases(companies),]

# Create a new data frame containing only rows with no missing data
companies_new <- na.omit(companies)

# Replace
#
# Eliminate all missing values from a data frame
na.omit(companies)

# Eliminate all missing values from all values in a column
na.omit(companies$Status)

# Replace all NA's in a data frame with '0'
companies[is.na(companies)] <- 0

# Replace all NA's in a data frame column with '0'
companies$Num_widgets[is.na(companies$Num_widgets)] <- 0

# Replace all NA's in a column with the median value of the column
companies$Num_widgets[is.na(companies$Num_widgets)] <- median(companies$Num_widgets)

## 2. Fixing Errors
##
##   c. Look for and remove incorrect data (impossible values, duplicates, typos, and extra spaces)
##

# Recode impossible values to missing
#
# If you know that a particular range of values for a variable is invalid, you can set those values
# as missing so as not to throw off your analysis later on:

# Recode negative (impossible) values in the Num_widgets column to NA
companies$Num_widgets[companies$Num_widgets < 0] <- NA

# Duplicates
#
# Are any of the rows in our data frame duplicated?
# Returns the array index of the first duplicate if any, otherwise 0.
anyDuplicated(companies)

    # a	Dufus & Dingus Ltd.	            	500000	1 	yes	1/1/14 10:00
    # b	Snooty Pants Fashion	silver     	100000	5	  no	1/1/14 13:24
    # b	Snooty Pants Fashion	silver     	100000	5	  no	1/1/14 13:24
    # b	Snooty Pants Fashion	silver     	100000	5	  no	1/1/14 13:24
    # c	Harry Ham Handlers	  gold	      123409	67	no	1/1/14 15:05

# Logical vector that shows duplicates
duplicated(companies)

# Row indeces of duplicates
# https://stackoverflow.com/questions/12495345/find-indices-of-duplicated-rows
which(duplicated(companies) | duplicated(companies[nrow(companies):1, ],fromLast = TRUE)[nrow(companies):1])

# Works too. Why use the above command?
which(duplicated(companies))

# Create a new data frame of only unique rows
unique_companies <- unique(companies)

# Same using the dplyr package
library(dplyr)
unique_companies <- companies %>% distinct()

# Remove duplicated rows based on duplication in a specific column
companies %>% distinct(Account_Name, .keep_all = TRUE)

# For more details you can use a table to find duplicated values in columns that should contain unique
# values only. Then you can look at the associated full records to see what kind of duplication it is
# (e.g., full row vs. mistakenly entered Account_Name)

# Lists the values of 'Account_Name' and the number of times they occur
occurrences <- data.frame(table(companies$Account_Name))

# tells you which ids occurred more than once.
occurrences[occurrences$Freq > 1,]

# Returns the records that contain the duplicated 'Account_Name'
companies[companies$Account_Name %in% occurrences$Var1[occurrences$Freq > 1],]

# Typos
#
# Identifiy typos in status categories...
table(companies$Status, useNA = "ifany")

# then fix them
companies$Status[companies$Status == "bornze"] <- "bronze"

# Same for the 'Complete' column
table(companies$Complete, useNA = "ifany")
companies$Complete[companies$Complete == "yess"] <- "yes"
companies$Complete[companies$Complete == "NOT"] <- "no"

# Removing Extra Spaces
#
# Eliminate all leading and trailing white space from every value in the data frame
# sapply returns a matrix, so we have to cast companies_no_ws back as a data frame.
companies_no_ws <- as.data.frame(sapply(companies, function(x) trimws(x)), stringsAsFactors = FALSE)

# Works on columns
# Removes leading and trailing white space from specific columns
library(stringr)
companies$Complete <- str_trim(companies$Complete)

# Remove extra spaces within account names
companies$Account_Name <- gsub("\\s+"," ", companies$Account_Name)

# Fixing case issues with categorical data
#
# Look at the different status categories again...
table(companies$Status, useNA = "ifany")

# ...and change them all to lower case
companies$Status <- sapply(companies$Status, tolower)

# check your work
table(companies$Status, useNA = "ifany")

## 2. Fixing Errors
##
##   d. Errors vs. Artifacts
##

# Sometimes during the import, organization, or cleaning stages of a project you inadvertantly introduce
# artifacts into your data. For example, when you import data in Excel it sometimes chooses the wrong data
# type for one or more of your columns (assigning a column with eight digit numeric values as type 'date').
# Keep this in mind so you don't carry these artifacts into your analysis steps.

## 3. Standardize values
##
##   a. Scaling (changing the range of data)
##

# https://www.thekerneltrip.com/statistics/when-scale-my-data/
# Scaling vs. normalization: https://www.quora.com/When-should-you-perform-feature-scaling-and-mean-normalization-on-the-given-data-What-are-the-advantages-of-these-techniques

# If you want to compare columns that are on a different scale, you need to change both sets of values to
# use a common scale. Algorithms such as SVM and KNN treat a change of '1' in a value with the same importance.

# https://stackoverflow.com/questions/15215457/standardize-data-columns-in-r
dat <- data.frame(x = rnorm(10, 30, .2), y = runif(10, 3, 5))
scaled.dat <- scale(dat)

# check that we get mean of 0 and sd of 1
colMeans(scaled.dat)  # faster version of apply(scaled.dat, 2, mean)
apply(scaled.dat, 2, sd)

## 3. Standardize values
##
##   b. Normalization (changing the shape of the distribution of the data)
##

# Needed when running algorithms that assume a normal distribution such as t-test, ANOVA, linear regression,
# LDA, and Gaussian Naive Bayes.
# We can make a "right-skewed" variable in the following manner:
# [a] drawing from a (standard)-normal distribution, and then:
# [b] exponentiating the results

x <- exp(rnorm(100,0,1))  # Combined [a] and [b]

hist(x)           # Plot the original right-skewed variable;
hist(log(x))      # plot the logged-version of the variable.

##   4. Dimensionality reduction: Can you get rid of any columns?
##      a. High ratio of missing values (based on a determined threshold)
##      b. High correlation with other variable(s)
##      c. Various methods discussed here

## 5. Repeat visualization

library(ggplot2)
ggplot(companies, aes(x = Status, fill = Complete)) + geom_bar()

## 6. Write a cleaned data frame to a .csv file
write.csv(companies, "/Users/mbc400/Box Sync/GitHub/data-cleaning-with-r/output/companies_cleaned.csv", row.names = FALSE)

## 7. Convert your data frame to a tibble

# With the 'dplyr' package, you can convert your data from to a tibble
companies_tbl <- as_tibble(companies_cleaned)
companies_tbl

# Check out the newly created tibble with 'glimpse'
glimpse(companies_tbl)

# Convert back to a data frame if you like
companies_cleaned <- as.data.frame(companies_tbl)

# test
median_gross <- companies %>%
  summarize (median_gross = median(Gross_Income_2013))


library(mnist)
data(mnist)
str(mnist)

train <- mnist$train$x
label <- mnist$train$y
rotate <- function(mat) {
    t(mat[nrow(mat):1, , drop = FALSE])
}

get_image <- function(i) {
    image_1 <- which(train[i, ] != 0)
    img_x <- image_1 %% 28
    img_x[which(img_x == 0)] <- 28
    img_y <- -floor(image_1 / 28)

    img_x <- img_x / 28
    img_y <- img_y / 28 + 1

    out <- list(x = img_x,
                y = img_y)
    return(out)
}

par(mfrow = c(3, 3))
for (i in seq(9)) {
    print(label[i])
    plot(get_image(i))
}

dev.new()
image(rotate(t(matrix((train[3, ]), nrow = 28, byrow = F))))


#calculates autocorrelation with each another

rm(list=ls())
rutba<-list.files("C:\\kindle_patrika\\PDB\\pdb_MoserFear\\")

for( retiwalu in rutba){

 zhumka<-substr(retiwalu,1,(nchar(retiwalu)-16)  )    #takes file name
 chipku<-paste("C:\\kindle_patrika\\PDB\\pdb_MoserFear\\",retiwalu,sep="")
pas<-read.table(chipku,skip=1)

potential<-pas[,4]
mean<-mean(potential)

N<-length(potential)

surya<-NULL   #for appending cor value
kai_zale<-NULL  #for appending t-value

for(jahan in seq_len(N-1) ){   #for each lag

k<-jahan  #for which lag

up_k<-0
for(i in seq_len(N-k)){
sadha_job<-(potential[i]-mean)*(potential[i+k]-mean)
up_k<-up_k+sadha_job
} #up_k

down_k<-0
for (j in seq_len(N) ){
flex<-(potential[j]-mean)**2
down_k<-down_k+flex
} #down_k

r_k<-up_k/down_k   #calculates correlation coe value
surya<-append(surya,r_k)

thumka<-r_k*(sqrt(N-2/1-(r_k)**2) )  #calculates t-value
kai_zale<-append(kai_zale,thumka)
#print(paste("r--> ",r_k,"  t--> ",thumka ) )

rm(up_k)
rm(down_k)
}  #for each lag

#writing each t-valued file
pani_lao<-cbind(surya,kai_zale,deparse.level=0)
lexicon<-paste("C:\\kindle_patrika\\PDB\\pdb_rajaRampool\\",zhumka,"_r_k",".pdb",sep="")
write.table(pani_lao,lexicon,col.names=c("r-value","t-value"),row.names=F)

} #for folder iterating


is.even <- function(x) {
	x = x / 2
	return(round(x) == x)
}


 DSPSVX Example Program Results

 Solution(s)
             1          2
 1     -5.0000     2.0000
 2     -2.0000     3.0000
 3      1.0000     4.0000
 4      4.0000     1.0000

 Backward errors (machine-dependent)
       1.4E-16    1.0E-16

 Estimated forward error bounds (machine-dependent)
       2.5E-14    3.2E-14

 Estimate of reciprocal condition number
       1.3E-02


library(randomForest)

dat<-read.csv("RF_datafile.csv", header=T)
#code probability cut-offs
for (i in 1:nrow(dat)) {

  if (dat$Epp[i] >=0.95) {
    dat$P0.95[i] <- "E"
  } else if (dat$Epp[i] <=0.05) {
    dat$P0.95[i] <- "B"
  } else
    dat$P0.95[i] <- "NA"

  if (dat$Epp[i] >=0.9) {
    dat$P0.9[i] <- "E"
  } else if (dat$Epp[i] <=0.1) {
    dat$P0.9[i] <- "B"
  } else
    dat$P0.9[i] <- "NA"

  if (dat$Epp[i] >=0.8) {
    dat$P0.8[i] <- "E"
  } else if (dat$Epp[i] <=0.2) {
    dat$P0.8[i] <- "B"
  } else
    dat$P0.8[i] <- "NA"

  if (dat$Epp[i] >=0.7) {
    dat$P0.7[i] <- "E"
  } else if (dat$Epp[i] <=0.3) {
    dat$P0.7[i] <- "B"
  } else
    dat$P0.7[i] <- "NA"
}

dat[dat=="-999"]<-NA

#beige
bat<-dat[,c(33,8:14)]
bat<-bat[!(bat$P0.9 =="NA"),]
bat<-na.omit(bat)
bat$P0.9<-as.factor(bat$P0.9)
table(bat$P0.9)

bat$Family<-as.factor(bat$Family)
bat$Zoogeographicprovince<-as.factor(bat$Zoogeographicprovince)

RF<-randomForest(P0.9 ~., data=bat, importance=TRUE, ntree=1000, nperm=100)
RF

#downsample
for (i in 1:100) {
  Btemp=bat[bat$P0.9=="B",]
  Esamp=bat[bat$P0.9=="E",]
  Bsamp<-Btemp[(sample(nrow(Btemp), size=17)),]

  bat_samp=rbind(Bsamp, Esamp)

  RF<-randomForest(P0.9 ~., data=bat_samp, importance=TRUE, ntree=1000, nperm=100)

  imp=RF$importance
  write.table(imp,file="RF_samp_imp_beige.csv", sep=",", append=T, col.names=!file.exists("RF_samp_imp_beige.csv"))

  err=RF$err.rate
  write.table(err, file="RF_samp_error_beige.csv", sep=",", row.names=FALSE, col.names=FALSE, append=T)

}

oob<-read.csv("RF_samp_error_beige.csv", header=FALSE)

mean(oob$V1)
mean(oob$V2)
mean(oob$V3)

#import RF_samp_imp_beige.csv
m<-aggregate(i[,4], list(i$var), mean)
write.csv(m, file="RF_mean_imp_beige.csv", quote=FALSE, row.names=FALSE)

#green+pink
bat<-dat[,c(33,15,16,19,20,21,23,24,25,27,28,29,31)]
bat<-bat[!(bat$P0.9 =="NA"),]
bat<-na.omit(bat)
bat$P0.9<-as.factor(bat$P0.9)
table(bat$P0.9)

bat$breeding<-as.factor(bat$breeding)
bat$dietaryniche<-as.factor(bat$dietaryniche)
bat$roosting<-as.factor(bat$roosting)

RF<-randomForest(P0.9 ~., data=bat, importance=TRUE, ntree=1000, nperm=100)
RF

#downsample
for (i in 1:100) {
  Btemp=bat[bat$P0.9=="B",]
  Esamp=bat[bat$P0.9=="E",]
  Bsamp<-Btemp[(sample(nrow(Btemp), size=7)),]

  bat_samp=rbind(Bsamp, Esamp)

  RF<-randomForest(P0.9 ~., data=bat_samp, importance=TRUE, ntree=1000, nperm=100)

  imp=RF$importance
  write.table(imp,file="RF_samp_imp_pinkgreen.csv", sep=",", append=T, col.names=!file.exists("RF_samp_imp_pinkgreen.csv"))

  err=RF$err.rate
  write.table(err, file="RF_samp_error_pinkgreen.csv", sep=",", row.names=FALSE, col.names=FALSE, append=T)

}

oob<-read.csv("RF_samp_error_pinkgreen.csv", header=FALSE)

mean(oob$V1)
mean(oob$V2)
mean(oob$V3)

#import RF_samp_imp_beige.csv
m<-aggregate(i[,4], list(i$var), mean)
write.csv(m, file="RF_mean_imp_beige.csv", quote=FALSE, row.names=FALSE)

#beige+pink
bat<-dat[,c(33,8:16,19,20,21,23,24,25,27,28,29,31)]
bat<-bat[!(bat$P0.9 =="NA"),]
bat<-na.omit(bat)
bat$P0.9<-as.factor(bat$P0.9)
table(bat$P0.9)

bat$breeding<-as.factor(bat$breeding)
bat$dietaryniche<-as.factor(bat$dietaryniche)
bat$roosting<-as.factor(bat$roosting)
bat$Family<-as.factor(bat$Family)
bat$Zoogeographicprovince<-as.factor(bat$Zoogeographicprovince)

RF<-randomForest(P0.9 ~., data=bat, importance=TRUE, ntree=1000, nperm=100)
RF

#downsample
for (i in 1:100) {
  Btemp=bat[bat$P0.9=="B",]
  Esamp=bat[bat$P0.9=="E",]
  Bsamp<-Btemp[(sample(nrow(Btemp), size=7)),]

  bat_samp=rbind(Bsamp, Esamp)

  RF<-randomForest(P0.9 ~., data=bat_samp, importance=TRUE, ntree=1000, nperm=100)

  imp=RF$importance
  write.table(imp,file="RF_samp_imp_pinkgreen.csv", sep=",", append=T, col.names=!file.exists("RF_samp_imp_pinkgreen.csv"))

  err=RF$err.rate
  write.table(err, file="RF_samp_error_pinkgreen.csv", sep=",", row.names=FALSE, col.names=FALSE, append=T)

}

oob<-read.csv("RF_samp_error_pinkgreen.csv", header=FALSE)

mean(oob$V1)
mean(oob$V2)
mean(oob$V3)

#import RF_samp_imp_beige.csv
m<-aggregate(i[,4], list(i$var), mean)
write.csv(m, file="RF_mean_imp_beige.csv", quote=FALSE, row.names=FALSE)

#######OLD AGAIN#########
#P = 0.95 predict model probs with all spatial variables
bat<-dat[,c(32,20:31)]
bat<-bat[!(bat$P0.95 =="NA"),]
bat<-na.omit(bat)
bat$P0.95<-as.factor(bat$P0.95)
table(bat$P0.95)
RF<-randomForest(P0.95 ~., data=bat, importance=TRUE, ntree=1000, nperm=100)
RF

#P = 0.9 predict model probs with all spatial variables
bat<-dat[,c(33,20:31)]
bat<-bat[!(bat$P0.9 =="NA"),]
bat<-na.omit(bat)
bat$P0.9<-as.factor(bat$P0.9)
table(bat$P0.9)
RF<-randomForest(P0.9 ~., data=bat, importance=TRUE, ntree=1000, nperm=100)
RF

#P = 0.8 predict model probs with all spatial variables
bat<-dat[,c(34,20:31)]
bat<-bat[!(bat$P0.8 =="NA"),]
bat<-na.omit(bat)
bat$P0.8<-as.factor(bat$P0.8)
table(bat$P0.8)
RF<-randomForest(P0.8 ~., data=bat, importance=TRUE, ntree=1000, nperm=100)
RF

#P = 0.7 predict model probs with all spatial variables
bat<-dat[,c(35,20:31)]
bat<-bat[!(bat$P0.7 =="NA"),]
bat<-na.omit(bat)
bat$P0.7<-as.factor(bat$P0.7)
table(bat$P0.7)
RF<-randomForest(P0.7 ~., data=bat, importance=TRUE, ntree=1000, nperm=100)
RF

#P = 0.95 predict model probs with change spatial variables
bat<-dat[,c(32,23,27,31)]
bat<-bat[!(bat$P0.95 =="NA"),]
bat<-na.omit(bat)
bat$P0.95<-as.factor(bat$P0.95)
table(bat$P0.95)
RF<-randomForest(P0.95 ~., data=bat, importance=TRUE, ntree=1000, nperm=100)
RF

#P = 0.9 predict model probs with change spatial variables
bat<-dat[,c(33,23,27,31)]
bat<-bat[!(bat$P0.9 =="NA"),]
bat<-na.omit(bat)
bat$P0.9<-as.factor(bat$P0.9)
table(bat$P0.9)
RF<-randomForest(P0.9 ~., data=bat, importance=TRUE, ntree=1000, nperm=100)
RF

#P = 0.8 predict model probs with change spatial variables
bat<-dat[,c(34,23,27,31)]
bat<-bat[!(bat$P0.8 =="NA"),]
bat<-na.omit(bat)
bat$P0.8<-as.factor(bat$P0.8)
table(bat$P0.8)
RF<-randomForest(P0.8 ~., data=bat, importance=TRUE, ntree=1000, nperm=100)
RF

#P = 0.7 predict model probs with change spatial variables
bat<-dat[,c(35,23,27,31)]
bat<-bat[!(bat$P0.7 =="NA"),]
bat<-na.omit(bat)
bat$P0.7<-as.factor(bat$P0.7)
table(bat$P0.7)
RF<-randomForest(P0.7 ~., data=bat, importance=TRUE, ntree=1000, nperm=100)
RF

#P = 0.95 predict model probs with change spatial variables + other
bat<-dat[,c(32,23,27,31,8:16,19)]
bat<-bat[!(bat$P0.95 =="NA"),]
bat<-na.omit(bat)
bat$P0.95<-as.factor(bat$P0.95)
table(bat$P0.95)
RF<-randomForest(P0.95 ~., data=bat, importance=TRUE, ntree=1000, nperm=100)
RF

#P = 0.9 predict model probs with change spatial variables + other
bat<-dat[,c(33,23,27,31,8:16,19)]
bat<-bat[!(bat$P0.9 =="NA"),]
bat<-na.omit(bat)
bat$P0.9<-as.factor(bat$P0.9)
table(bat$P0.9)
RF<-randomForest(P0.9 ~., data=bat, importance=TRUE, ntree=1000, nperm=100)
RF

#P = 0.8 predict model probs with change spatial variables + other
bat<-dat[,c(34,23,27,31,8:16,19)]
bat<-bat[!(bat$P0.8 =="NA"),]
bat<-na.omit(bat)
bat$P0.8<-as.factor(bat$P0.8)
table(bat$P0.8)
RF<-randomForest(P0.8 ~., data=bat, importance=TRUE, ntree=1000, nperm=100)
RF

#P = 0.7 predict model probs with change spatial variables + other
bat<-dat[,c(35,23,27,31,8:16,19)]
bat<-bat[!(bat$P0.7 =="NA"),]
bat<-na.omit(bat)
bat$P0.7<-as.factor(bat$P0.7)
table(bat$P0.7)
RF<-randomForest(P0.7 ~., data=bat, importance=TRUE, ntree=1000, nperm=100)
RF

#P = 0.95 DO data characteristics matter???
bat<-dat[,c(32,3:6)]
bat<-bat[!(bat$P0.95 =="NA"),]
bat<-na.omit(bat)
bat$P0.95<-as.factor(bat$P0.95)
table(bat$P0.95)
RF<-randomForest(P0.95 ~., data=bat, importance=TRUE, ntree=1000, nperm=100)
RF

#P = 0.8 DO data characteristics matter???
bat<-dat[,c(34,3:6)]
bat<-bat[!(bat$P0.8 =="NA"),]
bat<-na.omit(bat)
bat$P0.8<-as.factor(bat$P0.8)
table(bat$P0.8)
RF<-randomForest(P0.8 ~., data=bat, importance=TRUE, ntree=1000, nperm=100)
RF

#########
###OLD###
#########

dat$P0.9<-NA
dat$P0.8<-NA
dat$P0.7<-NA

#P = 0.9 predict model probs with change spatial variables
bat<-dat[,c(28,21,24,27)]
bat<-bat[!(bat$P0.9 =="NA"),]
bat<-na.omit(bat)
bat$P0.9<-as.factor(bat$P0.9)
table(bat$P0.9)
RF<-randomForest(P0.9 ~., data=bat, importance=TRUE, ntree=1000, nperm=100)
RF

#P = 0.9 predict model probs with all variables
bat<-dat[,c(28,10:27)]
bat<-bat[!(bat$P0.9 =="NA"),]
bat<-na.omit(bat)
bat$P0.9<-as.factor(bat$P0.9)
table(bat$P0.9)

bat$dietaryniche<-as.factor(bat$dietaryniche)
bat$breeding<-as.factor(bat$breeding)
bat$roostincaves<-as.factor(bat$roostincaves)
bat$roostintreesvegetation<-as.factor(bat$roostintreesvegetation)

RF<-randomForest(P0.9 ~., data=bat, importance=TRUE, ntree=1000, nperm=100)
RF

imp <- data.frame(importance(RF))
MDA<-imp[order(imp$MeanDecreaseAccuracy,decreasing = T),]
write.csv(MDA, file="MDA_0.9_allv.csv")

#P = 0.9 predict model probs with other variables
bat<-dat[,c(28,10:18)]
bat<-bat[!(bat$P0.9 =="NA"),]
bat<-na.omit(bat)
bat$P0.9<-as.factor(bat$P0.9)
table(bat$P0.9)

bat$dietaryniche<-as.factor(bat$dietaryniche)
bat$breeding<-as.factor(bat$breeding)
bat$roostincaves<-as.factor(bat$roostincaves)
bat$roostintreesvegetation<-as.factor(bat$roostintreesvegetation)

RF<-randomForest(P0.9 ~., data=bat, importance=TRUE, ntree=1000, nperm=100)
RF

imp <- data.frame(importance(RF))
MDA<-imp[order(imp$MeanDecreaseAccuracy,decreasing = T),]
write.csv(MDA, file="MDA_0.9_otherv.csv")

#P = 0.8 predict model probs with all spatial variables
bat<-dat[,c(29,19:27)]
bat<-bat[!(bat$P0.8 =="NA"),]
bat<-na.omit(bat)
bat$P0.8<-as.factor(bat$P0.8)
table(bat$P0.8)
RF<-randomForest(P0.8 ~., data=bat, importance=TRUE, ntree=1000, nperm=100)
RF

#P = 0.8 predict model probs with change spatial variables
bat<-dat[,c(29,21,24,27)]
bat<-bat[!(bat$P0.8 =="NA"),]
bat<-na.omit(bat)
bat$P0.8<-as.factor(bat$P0.8)
table(bat$P0.8)
RF<-randomForest(P0.8 ~., data=bat, importance=TRUE, ntree=1000, nperm=100)
RF

#P = 0.8 predict model probs with all variables
bat<-dat[,c(29,10:27)]
bat<-bat[!(bat$P0.8 =="NA"),]
bat<-na.omit(bat)
bat$P0.8<-as.factor(bat$P0.8)
table(bat$P0.8)

bat$dietaryniche<-as.factor(bat$dietaryniche)
bat$breeding<-as.factor(bat$breeding)
bat$roostincaves<-as.factor(bat$roostincaves)
bat$roostintreesvegetation<-as.factor(bat$roostintreesvegetation)

RF<-randomForest(P0.8 ~., data=bat, importance=TRUE, ntree=1000, nperm=100)
RF

#P = 0.8 predict model probs with other variables
bat<-dat[,c(29,10:18)]
bat<-bat[!(bat$P0.8 =="NA"),]
bat<-na.omit(bat)
bat$P0.8<-as.factor(bat$P0.8)
table(bat$P0.8)

bat$dietaryniche<-as.factor(bat$dietaryniche)
bat$breeding<-as.factor(bat$breeding)
bat$roostincaves<-as.factor(bat$roostincaves)
bat$roostintreesvegetation<-as.factor(bat$roostintreesvegetation)

RF<-randomForest(P0.8 ~., data=bat, importance=TRUE, ntree=1000, nperm=100)
RF

#P = 0.7 predict model probs with all spatial variables
bat<-dat[,c(30,19:27)]
bat<-bat[!(bat$P0.7 =="NA"),]
bat<-na.omit(bat)
bat$P0.7<-as.factor(bat$P0.7)
table(bat$P0.7)
RF<-randomForest(P0.7 ~., data=bat, importance=TRUE, ntree=1000, nperm=100)
RF

#P = 0.7 predict model probs with change spatial variables
bat<-dat[,c(30,21,24,27)]
bat<-bat[!(bat$P0.7 =="NA"),]
bat<-na.omit(bat)
bat$P0.7<-as.factor(bat$P0.7)
table(bat$P0.7)
RF<-randomForest(P0.7 ~., data=bat, importance=TRUE, ntree=1000, nperm=100)
RF

#P = 0.7 predict model probs with all variables
bat<-dat[,c(30,10:27)]
bat<-bat[!(bat$P0.7 =="NA"),]
bat<-na.omit(bat)
bat$P0.7<-as.factor(bat$P0.7)
table(bat$P0.7)

bat$dietaryniche<-as.factor(bat$dietaryniche)
bat$breeding<-as.factor(bat$breeding)
bat$roostincaves<-as.factor(bat$roostincaves)
bat$roostintreesvegetation<-as.factor(bat$roostintreesvegetation)

RF<-randomForest(P0.7 ~., data=bat, importance=TRUE, ntree=1000, nperm=100)
RF

#P = 0.7 predict model probs with other variables
bat<-dat[,c(30,10:18)]
bat<-bat[!(bat$P0.7 =="NA"),]
bat<-na.omit(bat)
bat$P0.7<-as.factor(bat$P0.7)
table(bat$P0.7)

bat$dietaryniche<-as.factor(bat$dietaryniche)
bat$breeding<-as.factor(bat$breeding)
bat$roostincaves<-as.factor(bat$roostincaves)
bat$roostintreesvegetation<-as.factor(bat$roostintreesvegetation)

RF<-randomForest(P0.7 ~., data=bat, importance=TRUE, ntree=1000, nperm=100)
RF

#downsampling P = 0.7 other variables
bat<-dat[,c(30,10:18)]
bat<-bat[!(bat$P0.7 =="NA"),]
bat<-na.omit(bat)
bat$P0.7<-as.factor(bat$P0.7)
table(bat$P0.7)

bat$dietaryniche<-as.factor(bat$dietaryniche)
bat$breeding<-as.factor(bat$breeding)
bat$roostincaves<-as.factor(bat$roostincaves)
bat$roostintreesvegetation<-as.factor(bat$roostintreesvegetation)

for (i in 1:100) {
  Bsamp=bat[bat$P0.7=="B",]
  Etemp=bat[bat$P0.7=="E",]
  Esamp<-Etemp[(sample(nrow(Etemp), size=14)),]

  bat_samp=rbind(Bsamp, Esamp)

  RF<-randomForest(P0.7 ~., data=bat_samp, importance=TRUE, ntree=1000, nperm=100)

  imp=RF$importance
  write.table(imp,file="RF_samp_imp_otherv.csv", sep=",", append=T, col.names=!file.exists("RF_samp_imp_otherv.csv"))

  err=RF$err.rate
  write.table(err, file="RF_samp_error_otherv.csv", sep=",", row.names=FALSE, col.names=FALSE, append=T)

}

oob<-read.csv("RF_samp_error_otherv.csv", header=FALSE)

mean(oob$V1)
mean(oob$V2)
mean(oob$V3)

#import RF_samp_imp_otherv.csv
m<-aggregate(i[,4], list(i$var), mean)
write.csv(m, file="RF_mean_imp_otherv.csv", quote=FALSE, row.names=FALSE)

#downsampling P = 0.7 all variables
bat<-dat[,c(30,10:27)]
bat<-bat[!(bat$P0.7 =="NA"),]
bat<-na.omit(bat)
bat$P0.7<-as.factor(bat$P0.7)
table(bat$P0.7)

bat$dietaryniche<-as.factor(bat$dietaryniche)
bat$breeding<-as.factor(bat$breeding)
bat$roostincaves<-as.factor(bat$roostincaves)
bat$roostintreesvegetation<-as.factor(bat$roostintreesvegetation)

for (i in 1:100) {
  Bsamp=bat[bat$P0.7=="B",]
  Etemp=bat[bat$P0.7=="E",]
  Esamp<-Etemp[(sample(nrow(Etemp), size=11)),]

  bat_samp=rbind(Bsamp, Esamp)

  RF<-randomForest(P0.7 ~., data=bat_samp, importance=TRUE, ntree=1000, nperm=100)

  imp=RF$importance
  write.table(imp,file="RF_samp_imp_allv.csv", sep=",", append=T, col.names=!file.exists("RF_samp_imp_allv.csv"))

  err=RF$err.rate
  write.table(err, file="RF_samp_error_allv.csv", sep=",", row.names=FALSE, col.names=FALSE, append=T)

}

oob<-read.csv("RF_samp_error_allv.csv", header=FALSE)

mean(oob$V1)
mean(oob$V2)
mean(oob$V3)

#import RF_samp_imp_allv.csv
m<-aggregate(i[,4], list(i$var), mean)
write.csv(m, file="RF_mean_imp_allv.csv", quote=FALSE, row.names=FALSE)

############
#####OLD####
############

#predict e or c with spatial data - 0.9 cut-off
RF_datafile<-RF_datafile[,c(69,55:63)]
names(RF_datafile)
RF_datafile<-na.omit(RF_datafile)
RF_datafile<-RF_datafile[!(RF_datafile$Model_2_0.9 =="na"),]
RF_datafile$Model_2_0.9<-as.character(RF_datafile$Model_2_0.9)
RF_datafile$Model_2_0.9<-as.factor(RF_datafile$Model_2_0.9)
RF<-randomForest(Model_2_0.9 ~., data=RF_datafile, importance=TRUE, ntree=1000, nperm=100)
RF

RF_datafile<-RF_datafile[,c(69,57, 60, 63)]
names(RF_datafile)
RF_datafile<-na.omit(RF_datafile)
RF_datafile<-RF_datafile[!(RF_datafile$Model_2_0.9 =="na"),]
RF_datafile$Model_2_0.9<-as.character(RF_datafile$Model_2_0.9)
RF_datafile$Model_2_0.9<-as.factor(RF_datafile$Model_2_0.9)
RF<-randomForest(Model_2_0.9 ~., data=RF_datafile, importance=TRUE, ntree=1000, nperm=100)
RF

#predict e or c with spatial data - 0.8 cut-off
RF_datafile<-RF_datafile[,c(70,55:63)]
names(RF_datafile)
RF_datafile<-na.omit(RF_datafile)
RF_datafile<-RF_datafile[!(RF_datafile$Model_2_0.8 =="na"),]
RF_datafile$Model_2_0.8<-as.character(RF_datafile$Model_2_0.8)
RF_datafile$Model_2_0.8<-as.factor(RF_datafile$Model_2_0.8)
RF<-randomForest(Model_2_0.8 ~., data=RF_datafile, importance=TRUE, ntree=1000, nperm=100)
RF

RF_datafile<-RF_datafile[,c(70,57, 60, 63)]
names(RF_datafile)
RF_datafile<-na.omit(RF_datafile)
RF_datafile<-RF_datafile[!(RF_datafile$Model_2_0.8 =="na"),]
RF_datafile$Model_2_0.8<-as.character(RF_datafile$Model_2_0.8)
RF_datafile$Model_2_0.8<-as.factor(RF_datafile$Model_2_0.8)
RF<-randomForest(Model_2_0.8 ~., data=RF_datafile, importance=TRUE, ntree=1000, nperm=100)
RF

#change characters to factors
RF_datafile$dietaryniche<-as.factor(RF_datafile$dietaryniche)
RF_datafile$breeding<-as.factor(RF_datafile$breeding)
RF_datafile$roostinbulidings<-as.factor(RF_datafile$roostinbulidings)
RF_datafile$roostincaves<-as.factor(RF_datafile$roostincaves)
RF_datafile$roostintreesvegetation<-as.factor(RF_datafile$roostintreesvegetation)

#predict model probs with other data
RF_datafile<-RF_datafile[,c(65,12,13,37,40,44,45,46)]
names(RF_datafile)
RF_datafile<-na.omit(RF_datafile)
RF<-randomForest(e_pp ~., data=RF_datafile, importance=TRUE, ntree=1000, nperm=100)
RF

#e or c with other data (0.9)
RF_datafile<-RF_datafile[,c(69,12,13,37,40,44,45,46)]
names(RF_datafile)
RF_datafile<-na.omit(RF_datafile)
RF_datafile<-RF_datafile[!(RF_datafile$Model_2_0.9 =="na"),]
RF_datafile$Model_2_0.9<-as.character(RF_datafile$Model_2_0.9)
RF_datafile$Model_2_0.9<-as.factor(RF_datafile$Model_2_0.9)
RF<-randomForest(Model_2_0.9 ~., data=RF_datafile, importance=TRUE, ntree=1000, nperm=100)
RF

#e or c with other data (0.8)
RF_datafile<-RF_datafile[,c(70,12,13,37,40,44,45,46)]
names(RF_datafile)
RF_datafile<-na.omit(RF_datafile)
RF_datafile<-RF_datafile[!(RF_datafile$Model_2_0.8 =="na"),]
RF_datafile$Model_2_0.8<-as.character(RF_datafile$Model_2_0.8)
RF_datafile$Model_2_0.8<-as.factor(RF_datafile$Model_2_0.8)
RF<-randomForest(Model_2_0.8 ~., data=RF_datafile, importance=TRUE, ntree=1000, nperm=100)
RF

#IMPORTANCE
write.table(RF$importance, file="RF_0.9_other_imp.txt", sep="\t", quote=FALSE)

##DOWNSAMPLING
RF_datafile<-RF_datafile[,c(69,12,13,37,40,44,45,46)]
names(RF_datafile)
RF_datafile<-na.omit(RF_datafile)
RF_datafile<-RF_datafile[!(RF_datafile$Model_2_0.9 =="na"),]
RF_datafile$Model_2_0.9<-as.character(RF_datafile$Model_2_0.9)
RF_datafile$Model_2_0.9<-as.factor(RF_datafile$Model_2_0.9)
table(RF_datafile$Model_2_0.9)

for (i in 1:100) {
  Csamp=RF_datafile[RF_datafile$Model_2_0.9=="c",]
  Etemp=RF_datafile[RF_datafile$Model_2_0.9=="e",]
  Esamp<-Etemp[(sample(nrow(Etemp), size=8)),]

  RF_datafile_samp=rbind(Csamp, Esamp)

  RF<-randomForest(Model_2_0.9 ~., data=RF_datafile, importance=TRUE, ntree=1000, nperm=100)

  imp=RF$importance
  write.table(imp,file="RF_samp_imp.csv", sep=",", append=T, col.names=!file.exists("RF_samp_imp.csv"))

  err=RF$err.rate
  write.table(err, file="RF_samp_error.csv", sep=",", row.names=FALSE, col.names=FALSE, append=T)

}

oob<-read.csv("RF_samp_error.csv", header=FALSE)

mean(oob$V1)
mean(oob$V2)
mean(oob$V3)

#import RF_samp_imp.csv
names(i)<-c("var","c","e","MDA")

m<-aggregate(i[,4], list(i$var), mean)
write.table(m, file="RF_mean_imp.txt", sep="\t", quote=FALSE, row.names=FALSE)

#ttest
e<-subset(RF_datafile, Model_2_0.8=="e")
c<-subset(RF_datafile, Model_2_0.8=="c")
t.test(e$AdultBodyMass_g, c$AdultBodyMass_g)

#REGRESSION
for (i in 1:nrow(RF_datafile)) {
  if (RF_datafile$Model_2_0.9[i] == "e"){
    RF_datafile$ModelLevel[i]<-1
  } else {
    RF_datafile$ModelLevel[i]<-2
  }}

l<-lm(ModelLevel ~ AdultBodyMass_g, data=RF_datafile)
summary(l)

##########OLD#############
names(RF_datafile)

apply(RF_datafile_x, 2, function(RF_datafile_x)length(unique(RF_datafile_x)))
lapply(RF_datafile_x, class)

#just env data
RF_datafile_x<-RF_datafile[,c(10,55:63)]
names(RF_datafile_x)
RF_datafile_x<-na.omit(RF_datafile_x)
RF<-randomForest(Model ~., data=RF_datafile_x, importance=TRUE, ntree=1000, nperm=100)
RF

RF_datafile_x<-RF_datafile[,c(10,57, 60, 63)]
names(RF_datafile_x)
RF_datafile_x<-na.omit(RF_datafile_x)
RF<-randomForest(Model ~., data=RF_datafile_x, importance=TRUE, ntree=1000, nperm=100)
RF

#predcit model C, E, or B
RF_datafile_x<-RF_datafile[,c(10,12,13,37,40,44,45,46,57,60,63)]
names(RF_datafile_x)
RF_datafile_x<-na.omit(RF_datafile_x)
RF<-randomForest(Model ~., data=RF_datafile_x, importance=TRUE, ntree=1000, nperm=100)
RF

table(RF_datafile_x$Model)

for (i in 1:100) {
  C=RF_datafile_x[RF_datafile_x$Model=="C",]
  B=RF_datafile_x[RF_datafile_x$Model=="B",]
  Bsamp<-B[(sample(nrow(B), size=13)),]
  E=RF_datafile_x[RF_datafile_x$Model=="E",]
  Esamp<-E[(sample(nrow(E), size=13)),]

  RF_datafile_y=rbind(C, Bsamp, Esamp)

  RF <- randomForest(Model ~ ., data=RF_datafile_y, importance=TRUE, ntree=1000)

  imp=RF$importance
  write.table(imp,file="RF_imp.csv", sep=",", row.names=FALSE, append=T)

  err=RF$err.rate
  write.table(err, file="RF_error.csv", sep=",", row.names=FALSE, col.names=FALSE, append=T)

}

oob<-read.csv("RF_error.csv", header=FALSE)
mean(oob$V1)

#Explore other things
RF_datafile_x<-RF_datafile[,c(7:10,12,13,37,40,44,45,46,57,60,63)]
RF_datafile_x$constant.size<-as.numeric(as.character(RF_datafile_x$constant.size))
RF_datafile_x<-na.omit(RF_datafile_x)

l<-lm(constant.size ~ areaChange_t500, data=RF_datafile_x)
summary(l)
l<-lm(constant.size ~ areaChange_t700, data=RF_datafile_x)
summary(l)
l<-lm(constant.size ~ areaChange_t900, data=RF_datafile_x)
summary(l)

RF_datafile_x$Holocene.bottleneck<-as.numeric(as.character(RF_datafile_x$Holocene.bottleneck))
RF_datafile_x<-na.omit(RF_datafile_x)

l<-lm(Holocene.bottleneck ~ areaChange_t500, data=RF_datafile_x)
summary(l)
l<-lm(Holocene.bottleneck ~ areaChange_t700, data=RF_datafile_x)
summary(l)
l<-lm(Holocene.bottleneck ~ areaChange_t900, data=RF_datafile_x)
summary(l)

RF_datafile_x$Holocene.expansion<-as.numeric(as.character(RF_datafile_x$Holocene.expansion))
RF_datafile_x<-na.omit(RF_datafile_x)

l<-lm(Holocene.expansion ~ areaChange_t500, data=RF_datafile_x)
summary(l)
l<-lm(Holocene.expansion ~ areaChange_t700, data=RF_datafile_x)
summary(l)
l<-lm(Holocene.expansion ~ areaChange_t900, data=RF_datafile_x)
summary(l)

for (i in 1:nrow(RF_datafile_x)) {
if (RF_datafile_x$Model[i] == "C"){
  RF_datafile_x$ModelLevel[i]<-1
} else if (RF_datafile_x$Model[i] == "E"){
  RF_datafile_x$ModelLevel[i]<-2
} else {
  RF_datafile_x$ModelLevel[i]<-3
}}

l<-lm(ModelLevel ~ areaChange_t500, data=RF_datafile_x)
summary(l)
l<-lm(ModelLevel ~ areaChange_t700, data=RF_datafile_x)
summary(l)
l<-lm(ModelLevel ~ areaChange_t900, data=RF_datafile_x)
summary(l)

##FIRST ROUND
#predict constant size
RF_datafile_x<-RF_datafile[,c(7,11,12,36,39,43,44,45,56,59,62)]
names(RF_datafile_x)
RF_datafile_x$constant.size<-as.numeric(as.character(RF_datafile_x$constant.size))
RF_datafile_x<-na.omit(RF_datafile_x)

RF<-randomForest(constant.size ~., data=RF_datafile_x, importance=TRUE, ntree=1000, nperm=100)
RF

RF_datafile_x<-RF_datafile[,c(7,56,59,62)]
names(RF_datafile_x)
RF_datafile_x$constant.size<-as.numeric(as.character(RF_datafile_x$constant.size))
RF_datafile_x<-na.omit(RF_datafile_x)

RF<-randomForest(constant.size ~., data=RF_datafile_x, importance=TRUE, ntree=1000, nperm=100)
RF

RF_datafile_x<-RF_datafile[,c(7, 11:34, 36,37,39, 43:45, 47:52, 54:62)]
names(RF_datafile_x)
RF_datafile_x$constant.size<-as.numeric(as.character(RF_datafile_x$constant.size))
RF_datafile_x<-na.omit(RF_datafile_x)

RF<-randomForest(constant.size ~., data=RF_datafile_x, importance=TRUE, ntree=1000, nperm=100)
RF

#predict holocene expansion
RF_datafile_x<-RF_datafile[,c(8,11,12,36,39,43,44,45,56,59,62)]
names(RF_datafile_x)
RF_datafile_x$Holocene.expansion<-as.numeric(as.character(RF_datafile_x$Holocene.expansion))
RF_datafile_x<-na.omit(RF_datafile_x)

RF<-randomForest(Holocene.expansion ~., data=RF_datafile_x, importance=TRUE, ntree=1000, nperm=100)
RF

RF_datafile_x<-RF_datafile[,c(8, 11:34, 36,37,39, 43:45, 47:52, 54:62)]
names(RF_datafile_x)
RF_datafile_x$Holocene.expansion<-as.numeric(as.character(RF_datafile_x$Holocene.expansion))
RF_datafile_x<-na.omit(RF_datafile_x)

RF<-randomForest(Holocene.expansion ~., data=RF_datafile_x, importance=TRUE, ntree=1000, nperm=100)
RF

#predict holocene bottleneck
RF_datafile_x<-RF_datafile[,c(9,11,12,36,39,43,44,45,56,59,62)]
names(RF_datafile_x)
RF_datafile_x$Holocene.bottleneck<-as.numeric(as.character(RF_datafile_x$Holocene.bottleneck))
RF_datafile_x<-na.omit(RF_datafile_x)

RF<-randomForest(Holocene.bottleneck ~., data=RF_datafile_x, importance=TRUE, ntree=1000, nperm=100)
RF

RF_datafile_x<-RF_datafile[,c(9, 11:34, 36,37,39, 43:45, 47:52, 54:62)]
names(RF_datafile_x)
RF_datafile_x$Holocene.bottleneck<-as.numeric(as.character(RF_datafile_x$Holocene.bottleneck))
RF_datafile_x<-na.omit(RF_datafile_x)

RF<-randomForest(Holocene.bottleneck ~., data=RF_datafile_x, importance=TRUE, ntree=1000, nperm=100)
RF

##MDA results

mean<-aggregate(imps$MeanDecreaseAccuracy, list(imps$Variable), mean)
min<-aggregate(imps$MeanDecreaseAccuracy, list(imps$Variable), min)
max<-aggregate(imps$MeanDecreaseAccuracy, list(imps$Variable), max)
head(mean)
head(min)
head(max)
n<-merge(mean,min,by="Group.1")
n<-merge(n,max,by="Group.1")
names(n)<-c("Variable","mean","min","max")
head(n)
write.csv(n, file="pinkgreen_avg_mda.csv", row.names=FALSE)


#' diag
#'
#' Create a diagonal matrix from a vector, or alternatively, get the vector of
#' diagonal entries from a matrix.
#'
#' @param x
#' fmlmat vector or matrix.
#' @param nrow,ncol
#' The dimension of the resulting matrix if specified.
#' @param names
#' Ignored.
#'
#' @aliases diag,fmlmat-method
#'
#' @name diag
#' @rdname diag
#' @export
setMethod("diag", signature(x="fmlmat"),
  function(x, nrow, ncol, names=TRUE)
  {
    # get vector from matrix
    if (missing(nrow) && missing(ncol))
    {
      if (!is_mat(DATA(x)))
        stop("'x' is an array, but not one-dimensional.")

      ret = skeleton_vec(x)
      DATA(x)$diag(ret)
    }
    # create matrix
    else
    {
      if (!is_vec(DATA(x)))
        stop("'nrow' or 'ncol' cannot be specified when 'x' is a matrix")

      if (missing(ncol))
        ncol = nrow
      if (missing(nrow))
        nrow = ncol

      ret = skeleton_mat(x)
      ret$resize(nrow, ncol)
      ret$fill_diag(DATA(x))
    }

    wrapfml(ret)
  }
)


Edge Path 0:
1 -> 4
4 -> 3
3 -> 5
5 -> 1
1 -> 2
2 -> 3
3 -> 1


#' Create a tidy stats data frame from an afex aov object
#'
#' \code{tidy_stats.aov} takes an afex aov object and converts the object to a
#' tidy stats data frame.
#'
#' @param model Output of afex's \code{aov_ez}, \code{aov_car}, or \code{aov_4}
#' @param args Unused
#'
#' @examples
#' # Check if afex package is available
#' if(!requireNamespace("afex", quietly = TRUE)) {
#'
#'   message(paste0("Package 'afex' is needed for this example to work. ",
#'               "Please install it."), .call = FALSE)
#' } else {
#'
#'   # Load data
#'   data(obk.long, package = "afex")
#'
#'   # Conduct an ANOVA
#'   afex_aov <- afex::aov_4(value ~ treatment * gender + (phase * hour | id),
#'                           data = obk.long, observed = "gender")
#'
#'   # Tidy stats
#'   tidy_stats(afex_aov)
#' }
#'
#' @export

tidy_stats.afex_aov <- function(model, args = NULL) {

  # Convert model output to a data frame
  output <- tibble::as_tibble(model$anova_table, rownames = "term")

  # Rename columns
  output <- rename_columns(output)

  # Add term number
  output <- dplyr::mutate(output, term_nr = 1:n())

  # Tidy stats
  output <- output %>%
    tidyr::gather("statistic", "value", -term, -term_nr) %>%
    dplyr::arrange(term_nr)

  # Set the type of analysis
  output <- mutate(output, method = "ANOVA {afex}")

  # Reorder columns
  output <- dplyr::select(output, term_nr, everything())

  return(output)
}


igraph2D3<- function (g, group, what = "both")
{

if (!("igraph" %in% class(g)))
  stop("g must be an igraph class object.", call. = FALSE)
if (!(what %in% c("both", "links", "nodes")))
  stop("what must be either \"nodes\", \"links\", or \"both\".",
       call. = FALSE)

temp_nodes <- V(g) %>% as.matrix %>% data.frame
temp_nodes$name <- row.names(temp_nodes)
names(temp_nodes) <- c("id", "name")
temp_nodes$id <- temp_nodes$id - 1
nodes <- temp_nodes$name %>% data.frame %>% setNames("name")

if (!missing(group)) {
  group <- as.matrix(group)
  if (nrow(nodes) != nrow(group))
    stop("group must have the same number of rows as the number of nodes in g.",
         call. = FALSE)
  nodes <- cbind(nodes, group)
}
row.names(nodes) <- NULL
links <- as_data_frame(g, what = "edges")
links <- merge(links, temp_nodes, by.x = "from", by.y = "name")
links <- merge(links, temp_nodes, by.x = "to", by.y = "name")
# if (ncol(links) == 5) {
  # links <- links[, c("id.x", "id.y", "value")] %>% setNames(c("source",
                                                              # "target", "value"))
# }
# else {
  links <- links[, c("id.x", "id.y")] %>% setNames(c("source",
                                                     "target"))
# }
if (what == "both") {
  return(list(links = links, nodes = nodes))
}
else if (what == "links") {
  return(links)
}
else if (what == "nodes") {
  return(nodes)
}
}


#' mph2knots
#'
#' Conversion speed from mile per hour in knots.
#'
#' @param numeric  mph Speed in mile per hour.
#' @return
#'
#'
#' @author  Istituto di Biometeorologia Firenze Italy  Alfonso Crisci \email{a.crisci@@ibimet.cnr.it}
#' @keywords  mph2knots
#'
#' @export
#'
#'
#'
#'
mph2knots<-function(mph)
{
  return(mph * 0.868976);
}


MARSSkemcheck <- function(MLEobj) {
  # This checks that the model can be handled by the MARSSkem algorithm
  # Most of this is implementing the restrictions in Summary of Requirements for Degenerate Models in derivation
  MODELobj <- MLEobj$marss
  fixed <- MODELobj$fixed
  free <- MODELobj$free
  par.dims <- attr(MODELobj, "model.dims")
  m <- par.dims[["x"]][1]
  n <- par.dims[["y"]][1]
  TT <- par.dims[["data"]][2]
  pseudolim <- 1E-8
  ok <- TRUE
  msg <- NULL

  # If TT=2 then kf will break
  if (TT <= 2) {
    msg <- c(msg, "The number of time steps is <=2.\nMore than 2 data points are needed to estimate parameters.\n")
    ok <- FALSE
  }

  ############ Check that if fixed, B is within the unit circle
  for (t in 1:max(dim(free$B)[3], dim(fixed$B)[3])) {
    ifixed <- min(t, dim(fixed$B)[3])
    if (is.fixed(free$B[, , ifixed, drop = FALSE])) { # works on 3D matrices
      # parmat needs MODELobj and par list
      if (is.null(MLEobj$par$B)) tmpparB <- MLEobj$start$B else tmpparB <- MLEobj$par$B
      tmp.MLEobj <- list(marss = MODELobj, par = list(B = tmpparB)) # B is fixed but par might have cols from other times
      parB <- parmat(tmp.MLEobj, "B", t = t)$B
      if (!all(abs(Re(eigen(parB, only.values = TRUE)$values)) <= 1)) {
        msg <- c(msg, " All the eigenvalues of B must be within the unit circle: all(abs(Re(eigen(fixed$B)$values))<=1)\n")
        ok <- FALSE
      }
    }
  } # end for over time to check B

  ############ Check that if R has 0s, then the corresponding row of A and Z are fixed
  # See Summary of Requirements for Degenenate Models in EMDerivations.pdf
  el <- "R"
  # extracts the r=0 rows (or cols)
  diag.rows <- 1 + 0:(par.dims[[el]][1] - 1) * (par.dims[[el]][1] + 1)
  Tmax <- 0
  for (par.test in c("R", "Z", "A")) {
    Tmax <- max(Tmax, dim(fixed[[par.test]])[3], dim(free[[par.test]])[3])
  }

  if (is.null(MLEobj[["par"]])) MLEobj$par <- MLEobj$start
  # Run with MARSSkfss because it has more internal checks and error messages
  MLEobj$kf <- MARSSkfss(MLEobj)
  if (!MLEobj$kf$ok) {
    return(list(ok = FALSE, msg = c(MLEobj$kf$errors, msg)))
  }
  MLEobj$Ey <- MARSShatyt(MLEobj)
  msg.tmp <- NULL
  for (i in 1:TT) {
    ifixed <- min(i, dim(fixed[[el]])[3])
    ifree <- min(i, dim(free[[el]])[3])
    zero.diags <- is.fixed(free[[el]][diag.rows, , ifree, drop = FALSE], by.row = TRUE) & apply(fixed[[el]][diag.rows, , ifixed, drop = FALSE] == 0, 1, all) # fixed rows and 0
    if (any(zero.diags)) {
      II0 <- makediag(as.numeric(zero.diags))
      if (i <= Tmax) {
        for (par.test in c("Z", "A")) {
          II <- diag(1, par.dims[[par.test]][2])
          ifree.par <- min(i, dim(free[[par.test]])[3])
          dpart <- sub3D(free[[par.test]], t = ifree.par)
          par.not.fixed <- any(((II %x% II0) %*% dpart) != 0)

          if (par.not.fixed) {
            if (par.test == "Z") msg <- c(msg, paste("t=", i, ": For method=kem (EM), if an element of the diagonal of R is 0, the corresponding row of Z must be fixed. See MARSSinfo('AZR0').\n", sep = ""))
            if (par.test == "A") msg <- c(msg, paste("t=", i, ": For method=kem (EM), if an element of the diagonal of R is 0, the corresponding row of both A and D must be fixed. See MARSSinfo('AZR0').\n", sep = ""))
          }
        } # for par.test
      } # if par needs to be tested; don't need to do over all TT just up to Tmax

      Z <- parmat(MLEobj, "Z", t = i)$Z
      A <- parmat(MLEobj, "A", t = i)$A
      Z.R0 <- Z[zero.diags, , drop = FALSE]
      A.R0 <- A[zero.diags, , drop = FALSE]
      y.R0 <- MLEobj$Ey$ytT[zero.diags, i, drop = FALSE]
      y.resid <- y.R0 - Z.R0 %*% MLEobj$kf$xtT[, i, drop = FALSE] - A.R0
      if (any(y.resid > pseudolim)) {
        msg.tmp <- c(msg.tmp, paste(" Z, A, and y for the R=0 rows at time=", i, " do not agree. For the R=0 rows, E(y) must equal Z * E(x) + A.\n", sep = ""))
      }
    } # any zero.diags
  } # end for loop over time
  if (!is.null(msg)) {
    msg <- c(msg, msg.tmp[1:min(10, length(msg.tmp))]) # error msgs could be really long, only print first 10
    ok <- FALSE
  }

  ############ Check that II_q^{0} is time constant
  # See Summary of Requirements for Degenenate Models in EMDerivations.pdf
  Tmax <- 0
  for (par.test in c("Q")) {
    Tmax <- max(Tmax, dim(fixed[[par.test]])[3], dim(free[[par.test]])[3])
  }
  II0 <- list()
  for (i in 1:Tmax) {
    for (el in c("Q")) {
      ifixed <- min(i, dim(fixed[[el]])[3])
      ifree <- min(i, dim(free[[el]])[3])
      diag.rows <- 1 + 0:(par.dims[[el]][1] - 1) * (par.dims[[el]][1] + 1)
      zero.diags <- is.fixed(free[[el]][diag.rows, , ifree, drop = FALSE], by.row = TRUE) & apply(fixed[[el]][diag.rows, , ifixed, drop = FALSE] == 0, 1, all) # fixed rows
      II0Q <- makediag(as.numeric(zero.diags))
      II0Q <- unname(II0[[el]])
    }
    if (i == 1) {
      II0Q.1 <- II0Q
    } else {
      if (!isTRUE(all.equal(II0Q, II0Q.1))) {
        msg <- c(msg, paste("t=", i, ": The placement of 0 variances in Q must be time constant.\n", sep = ""))
        ok <- FALSE
      }
    }
  } # end for loop over time

  ############ Check that if R and Q both have 0s, then the U and Bs are appropriately fixed
  # See Summary of Requirements for Degenenate Models in EMDerivations.pdf
  Tmax <- 0
  for (par.test in c("R", "Q", "U", "B", "Z")) {
    Tmax <- max(Tmax, dim(fixed[[par.test]])[3], dim(free[[par.test]])[3])
  }
  II0 <- list()
  for (i in 1:Tmax) {
    for (el in c("R", "Q")) {
      ifixed <- min(i, dim(fixed[[el]])[3])
      ifree <- min(i, dim(free[[el]])[3])
      diag.rows <- 1 + 0:(par.dims[[el]][1] - 1) * (par.dims[[el]][1] + 1)
      zero.diags <- is.fixed(free[[el]][diag.rows, , ifree, drop = FALSE], by.row = TRUE) & apply(fixed[[el]][diag.rows, , ifixed, drop = FALSE] == 0, 1, all) # fixed rows
      II0[[el]] <- makediag(as.numeric(zero.diags))
    }
    for (el in c("B", "U")) {
      ifree <- min(i, dim(free[[el]])[3])
      # I don't know what par$Z will be.  I want to create a par$Z where there is a non-zero value for any potentially non-zero Z's
      tmp.MLEobj <- list(marss = MODELobj, par = list(Z = matrix(1, dim(free$Z)[2], 1)))
      tmp.MLEobj$marss$fixed$Z[tmp.MLEobj$marss$fixed$Z != 0] <- 1
      tmp.MLEobj$marss$free$Z[tmp.MLEobj$marss$free$Z != 0] <- 1
      parZ <- parmat(tmp.MLEobj, "Z", t = i)$Z
      II <- diag(1, par.dims[[el]][2])

      dpart <- sub3D(free[[el]], t = ifree)
      par.not.fixed <- any(((II %x% (II0$R %*% parZ %*% II0$Q)) %*% dpart) != 0)

      if (par.not.fixed) {
        msg <- c(msg, paste("t=", i, ": For method=kem (EM), if an element of the diagonal of R & Q is 0, the corresponding row of ", par.test, " must be fixed.\n", sep = ""))
        ok <- FALSE
      }
    } # for par.test
  } # end for loop over time

  ############ Check that B^{0} is fixed
  # See Summary of Requirements for Degenenate Models in EMDerivations.pdf
  Tmax <- 0
  for (par.test in c("B")) {
    Tmax <- max(Tmax, dim(fixed[[par.test]])[3], dim(free[[par.test]])[3])
  }
  II0 <- list()
  for (i in 1:Tmax) {
    for (el in c("Q")) {
      ifixed <- min(i, dim(fixed[[el]])[3])
      ifree <- min(i, dim(free[[el]])[3])
      diag.rows <- 1 + 0:(par.dims[[el]][1] - 1) * (par.dims[[el]][1] + 1)
      zero.diags <- is.fixed(free[[el]][diag.rows, , ifree, drop = FALSE], by.row = TRUE) & apply(fixed[[el]][diag.rows, , ifixed, drop = FALSE] == 0, 1, all) # fixed rows
      II0[[el]] <- makediag(as.numeric(zero.diags))
    }
    for (el in c("B")) {
      ifree <- min(i, dim(free[[el]])[3])
      II <- diag(1, par.dims[[el]][2])
      dpart <- sub3D(free[[el]], t = ifree)
      par.not.fixed <- any(((II %x% II0$Q) %*% dpart) != 0)

      if (par.not.fixed) {
        msg <- c(msg, paste("t=", i, ": If an element of the diagonal of Q is 0, the corresponding row and col of ", par.test, " must be fixed.\n", sep = ""))
        ok <- FALSE
      }
    } # for par.test
  } # end for loop over time

  ############ Check that if u^{0} or xi^{0} are estimated, B adjacency matrix is time invariant
  # See Summary of Requirements for Degenenate Models in EMDerivations.pdf
  Tmax <- 0
  for (par.test in c("U")) {
    Tmax <- max(Tmax, dim(fixed[[par.test]])[3], dim(free[[par.test]])[3])
  }
  II0 <- list()
  el <- "Q"
  ifixed <- min(i, dim(fixed[[el]])[3])
  ifree <- min(i, dim(free[[el]])[3])
  diag.rows <- 1 + 0:(par.dims[[el]][1] - 1) * (par.dims[[el]][1] + 1)
  zero.diags <- is.fixed(free[[el]][diag.rows, , ifree, drop = FALSE], by.row = TRUE) & apply(fixed[[el]][diag.rows, , 1, drop = FALSE] == 0, 1, all) # fixed rows
  II0[[el]] <- makediag(as.numeric(zero.diags))

  dpart <- sub3D(free$x0, t = 1)
  test.adj <- any((II0$Q %*% dpart) != 0)
  for (i in 1:Tmax) {
    dpart <- sub3D(free$U, t = 1)
    test.adj <- test.adj & any((II0$Q %*% dpart) != 0) # II0$Q required to be time constant above
  }

  if (test.adj) { # means x0^{0} or u^{0} being estimated
    Tmax <- 0
    for (par.test in c("U", "B")) {
      Tmax <- max(Tmax, dim(fixed[[par.test]])[3], dim(free[[par.test]])[3])
    }
    for (i in 1:Tmax) {
      el <- "B"
      ifree <- min(i, dim(free[[el]])[3])
      # I don't know what par$B will be.  I want to create a par$B where there is a non-zero value for any potentially non-zero B's
      tmp.MLEobj <- list(marss = MODELobj, par = list(B = matrix(1, dim(free$B)[2], 1)))
      tmp.MLEobj$marss$fixed[[el]][tmp.MLEobj$marss$fixed[[el]] != 0] <- 1
      tmp.MLEobj$marss$free[[el]][tmp.MLEobj$marss$free[[el]] != 0] <- 1
      adjB <- parmat(tmp.MLEobj, el, t = i)[[el]]
      adjB[adjB != 0] <- 1
      adjB <- unname(adjB)
      if (i == 1) {
        adjB.1 <- adjB
      } else {
        if (!isTRUE(all.equal(adjB, adjB.1))) {
          msg <- c(msg, paste("t=", i, ": If u^{0} or xi^{0} are estimated, the adjacency matrix specified by B must be time constant.\n", sep = ""))
          ok <- FALSE
        }
      }
    } # end for loop over time
  } # if the adj test needs to be done

  ############ Check that II_q^{d} and II_q^{is} are time constant
  # See Summary of Requirements for Degenenate Models in EMDerivations.pdf
  Tmax <- 0
  for (par.test in c("Q")) {
    Tmax <- max(Tmax, dim(fixed[[par.test]])[3], dim(free[[par.test]])[3])
  }
  IIz <- IIp <- OMGz <- OMGp <- IId <- IIis <- list()
  for (i in 1:Tmax) {
    el <- "Q"
    ifixed <- min(i, dim(fixed[[el]])[3])
    ifree <- min(i, dim(free[[el]])[3])
    diag.rows <- 1 + 0:(par.dims[[el]][1] - 1) * (par.dims[[el]][1] + 1)
    zero.diags <- is.fixed(free[[el]][diag.rows, , ifree, drop = FALSE], by.row = TRUE) & apply(fixed[[el]][diag.rows, , ifixed, drop = FALSE] == 0, 1, all) # fixed rows
    IIz[[el]] <- makediag(as.numeric(zero.diags))
    IIp[[el]] <- diag(1, par.dims[[el]][1]) - IIz[[el]]
    OMGz[[el]] <- diag(1, par.dims[[el]][1])[diag(IIz[[el]]) == 1, , drop = FALSE]
    OMGp[[el]] <- diag(1, par.dims[[el]][1])[diag(IIp[[el]]) == 1, , drop = FALSE]

    # I don't know what par$B will be.  I want to create a par$B where there is a non-zero value for any potentially non-zero B's
    tmp.MLEobj <- list(marss = MODELobj, par = list(B = matrix(1, dim(free$B)[2], 1)))
    tmp.MLEobj$marss$fixed$B[tmp.MLEobj$marss$fixed$B != 0] <- 1
    tmp.MLEobj$marss$free$B[tmp.MLEobj$marss$free$B != 0] <- 1
    Adj.mat <- parmat(tmp.MLEobj, "B", t = i)$B
    Adj.mat[Adj.mat != 0] <- 1
    Adj.mat <- unname(Adj.mat)
    Adj.mat.pow.m <- matrix.power(Adj.mat, m) # to find all the linkages

    Q.0.rows.of.Adj.mat <- OMGz[[el]] %*% Adj.mat.pow.m
    # These are the columns corresponding to the directly stochastic bit: Q.0.rows.of.Adj.mat%*%t(OMGp$Q)
    if (dim(OMGp[[el]])[1] != 0) {
      tmp <- Q.0.rows.of.Adj.mat
      # which rows of the + columns are all zero
      if (dim(Q.0.rows.of.Adj.mat)[1] != 0) tmp <- apply(Q.0.rows.of.Adj.mat %*% t(OMGp[[el]]) == 0, 1, all)
      tmp <- t(OMGz[[el]]) %*% matrix(as.numeric(tmp), ncol = 1) # expand back outl 1s where the deterministic x's are
      IId[[el]] <- makediag(tmp)
      IId[[el]] <- unname(IId[[el]])
      IIis[[el]] <- diag(1, m) - IId[[el]] - IIp[[el]]
      IIis[[el]] <- unname(IIis[[el]])
    } else { # Q all 0
      IId[[el]] <- diag(1, par.dims[[el]][1])
      IIis[[el]] <- diag(0, par.dims[[el]][1])
    }
    if (i == 1) {
      IId.1 <- IId[[el]]
      IIis.1 <- IIis[[el]]
    } else {
      if (!isTRUE(all.equal(IId[[el]], IId.1))) {
        msg <- c(msg, paste("t=", i, ": The location of the deterministic x's must be time constant.\n", sep = ""))
        ok <- FALSE
      }
      if (!isTRUE(all.equal(IIis[[el]], IIis.1))) {
        msg <- c(msg, paste("t=", i, ": The location of the indirectly stochastic x's must be time constant.\n", sep = ""))
        ok <- FALSE
      }
    }
  } # end for loop over time

  return(list(ok = ok, msg = msg))
}


# install package rstudioapi and set file path as current directory
if (!require("rstudioapi")) { install.packages("rstudioapi", dependencies = T) }
library("rstudioapi")
setwd(dirname(rstudioapi::getActiveDocumentContext()$path))

# install missing packages, load packages, sources
source('environment.r')
environment.start()

# load otu table and tree
data.folder <- "data/otus/infants/"
workload <- otus.load(data.folder, "OTUs-Table.tab", "OTUs-NJTree.tre")

# load metadata
metadata <- as.matrix(read_excel('data/meta.xlsx'))
metadata[, 'ID'] <- str_pad(str_trim(metadata[, 'ID']), 3, pad = "0")

# extract individuals, timepoints
samples <- row.names(workload$otus)
individuals <- unlist(lapply(samples, function(i){substr(i, start = 2, stop = 4)}))
timepoints <- unlist(lapply(samples, function(i){substr(i, start = 5, stop = 7)}))

# build unique and ordered timepoint list
unique.timepoints <- as.vector(sort(unique(timepoints)))

# cluster data per timepoint
clusterings <- time.series.generate.clusterings(workload$otus, workload$otus.tree)

# generate time series from computed clusters of every timepoint
time.series <- time.series.generate(clusterings, samples)
#time.series <- cbind( metadata[, 'Group'], time.series)
#colnames(time.series)[1] <- '00'

write.table(time.series, file = paste(data.folder, 'time-series.txt', sep=''))

# generate transition matrix for selected time points
timepoint.chain <- c("01", "03")
timepoint.chain <- c("01", "03", "05", "07", "09", "12", "24", "MM")
timepoint.chain <- c("01", "03", "05", "07", "09", "12", "24")
transition.matrix <- markov.transition.matrix(time.series, timepoint.chain)
plots.network(transition.matrix, timepoint.chain)

timepoint.chain <- c("01","05")
transition.matrix <- markov.transition.matrix(time.series, timepoint.chain)
plots.network(transition.matrix, timepoint.chain)

timepoint.chain <- c("01","07")
transition.matrix <- markov.transition.matrix(time.series, timepoint.chain)
plots.network(transition.matrix, timepoint.chain)

timepoint.chain <- c("01","09")
transition.matrix <- markov.transition.matrix(time.series, timepoint.chain)
plots.network(transition.matrix, timepoint.chain)

timepoint.chain <- c("03","05")
transition.matrix <- markov.transition.matrix(time.series, timepoint.chain)
plots.network(transition.matrix, timepoint.chain)

timepoint.chain <- c("03","07")
transition.matrix <- markov.transition.matrix(time.series, timepoint.chain)
plots.network(transition.matrix, timepoint.chain)

g <- graph_from_adjacency_matrix(transition.matrix, weighted = T, mode = 'directed')
bn <- as.bn(g)
plot(bn)
#heatmap(transition.matrix, Rowv = NA, Colv = NA, scale = 'none', symm = T)

# generate svm classifiers for every timepoint
svm.classifiers <- svm.generate.classifiers(workload$otus, clusterings)
# rf.classifiers <- rf.generate.classifiers(workload$otus, clusterings)


# Dye bias correction
#
# Adjusts dye bias by scaling each color channel to have the same mean intensity.
#
# Infinium HumanMethylation450 BeadChip
# @param rg Cy5/Cy3 signal generated by \code{\link{read.rg}()}.
# @param probes Output from \code{\link{meffil.probe.info}()} compatible with \code{rg}.
# @param intensity Intensity of both color channels after correct (Default: 5000).
# @return Cy5/Cy3 signals with average intensity equal to \code{intensity}.
dye.bias.correct <- function(rg, probes, intensity=5000, verbose=F) {
    msg(verbose=verbose)
    stopifnot(is.rg(rg))
    stopifnot(intensity > 100)

    rg$R[,"Mean"] <- rg$R[,"Mean"] * intensity/calculate.intensity.R(rg, probes)
    rg$G[,"Mean"] <- rg$G[,"Mean"] * intensity/calculate.intensity.G(rg, probes)
    rg
}

calculate.intensity.R <- function(rg, probes) {
    addresses <- probes$address[which(probes$target %in% c("NORM_A", "NORM_T")
                                      & probes$dye == "R")]
    idx <- match(addresses, rownames(rg$R))
    idx <- na.omit(idx)
    if (length(idx) < 10) ## there are 93 in total
        stop("Seems like this IDAT file does not match the supplied chip annotation")

    mean(rg$R[idx,"Mean"], na.rm=T)
}

calculate.intensity.G <- function(rg, probes) {
    addresses <- probes$address[which(probes$target %in% c("NORM_G", "NORM_C")
                                      & probes$dye == "G")]
    idx <- match(addresses, rownames(rg$G))
    idx <- na.omit(idx)
    if (length(idx) < 10) ## there are 93 in total
        stop("Seems like this IDAT file does not match the supplied chip annotation")

    mean(rg$G[idx,"Mean"], na.rm=T)
}