###########################################
#Code for New infrared thermographs used for COVID-19 fever screening normalize elevated temperatures
#Author: Zachary Segal
#Date: 12/02/21
###########################################

# Initial Statistics and Plots --------------------------------------------------------------------

# Key --------------------------------------------------------------------
#BB is the Black Body we used as a target for testing
#Ex represents Extech on body mode unless otherwise specified; Black
#Surf represents Extech on Surface Mode
#FLir/flir represents Flir IRT; Brown
#Bems/bems/bem/b all represent the Bems IRT; Purple
#TVT/tvt/t all represent TVT IRT; Blue
#Dahua/Dah/dah/d represent Dahua IRT; Red
#Cert/cert/c represetns Certify IRT; deeppink
#Zk/zk/Z/z represetns ZKTeco IRT; darkgoldenrod
#Hik/hik/h/H represents Hikvision IRT; lightseagreen
#md/Md/m/m represents Meridian IRT; orange

# Bems --------------------------------------------------------------------

#Loading Data
bems = read.csv("/Users/zacharysegal/Downloads/IRT Specs FDA - Bems.csv")

#Ensuring all data is in range, removing nas, adding column for difference between device and BB
#In some rounds low or high temperatures were recorded that should not have been
bems = bems[bems$Blackbody.Temperature >= 35 & bems$Blackbody.Temperature <= 40,]
bems = bems[!is.na(bems$Blackbody.Temperature ),]
bems$Dev.Delta = as.numeric(bems$Device.Measurement) - as.numeric(bems$Blackbody.Temperature)
bems$Device.Measurement = as.numeric(bems$Device.Measurement)

##Comparing Device Deviation from BB and BB##
#Making a linear model to compare Device Deviation from BB and BB
BemsAc = lm(bems$Dev.Delta~ bems$Blackbody.Temperature)
summary(BemsAc)#Adjusted R-squared:  0.9978; Beta  -0.99688; P-value <2e-16 ***

##Comparing Device, Extech on Body Mode, and BB##
#Linear Models
BemsBB <- lm(bems$Device.Measurement ~ bems$Blackbody.Temperature); summary(BemsBB)
#Adjusted R-squared:  -0.04785; Beta 0.003117; P-Value 0.772

ExBB <- lm(bems$Ex.Body ~ bems$Blackbody.Temperature); summary(ExBB)
#Adjusted R-squared:  0.981; Beta 0.76234; P-Value < 2e-16 ***

#Ploting results
plot(bems$Blackbody.Temperature, bems$Device.Measurement,
     xlab = "Subject Temperature °C", ylab = "Device Temperature",
     main = "Bems, Flir, Extech vs Subject Temperature", lty = 1,
     ylim=c(34.5, 42.5), col = "purple" , bg = 'blue')
points(bems$Blackbody.Temperature,bems$Ex.Body,lty = 2, col = "black")
points(bems$Blackbody.Temperature, bems$FLIR.Measurement, lty = 3, col = "brown")
legend("topleft", bty = "n", legend = c( "Extech Body Adj. R sqrd .98; Beta 76", "Bems Adj. R sqrd <.01; Beta 0", "Flir Adj R sqrd .99; Beta 1"), text.col = c(1,"purple", "brown"), bg = "transparent", lty = c(1,2,3))
abline(BemsBB, col = "purple", lty = 2)
abline(ExBB, lty = 1)
abline(lty = 3, lm(bems$FLIR.Measurement ~ bems$Blackbody.Temperature), col = "brown")

#TVT --------------------------------------------------------------------

#Loading Data
tvt = read.csv("/Users/zacharysegal/Downloads/IRT Specs FDA - TVT.csv")

#Ensuring all data is in range, adding column for difference between device and BB
tvt = tvt[tvt$Blackbody.Temperature >= 35 & tvt$Blackbody.Temperature <= 40,]
tvt$Dev.Delta = as.numeric(tvt$Device.Measurement) - as.numeric(tvt$Blackbody.Temperature)

##Comparing Device Deviation from BB and BB##
#Making a linear model to compare Device Deviation from BB and BB
tvtAc = lm(tvt$Dev.Delta~tvt$Blackbody.Temperature); summary(tvtAc)
# Adjusted R-squared:   0.9683; beta  -0.78182; p-value 6.57e-16 ***
tvtAc2 = lm(log(tvt$Dev.Delta+4)~tvt$Blackbody.Temperature); summary(tvtAc2)
#Adjusted R-squared:  0.9871

##Comparing Device, Extech on Body Mode, and BB##
tvtBB <- lm(tvt$Device.Measurement ~ tvt$Blackbody.Temperature); summary(tvtBB)
#Adjusted R-squared:  0.6996; Beta  0.21818; p-value  1.41e-06 ***

ExBB <- lm(tvt$Ex.Body ~ tvt$Blackbody.Temperature); summary(ExBB)
#Adjusted R-squared:  0.9716; beta 0.74182; p-value < 2e-16 ***

#Plot
plot(tvt$Blackbody.Temperature, tvt$Device.Measurement,
     xlab = "Subject Temperature °C", ylab = "Device Temperature",
     main = "TVT, Flir, Extech vs Subject Temperature",
     ylim=c(34.5, 42.5), col = "blue", pch = 1)

points(tvt$Blackbody.Temperature,tvt$Ex.Body, col = "black", pch = 2)
points(tvt$Blackbody.Temperature,tvt$FLIR.Measurement, col = "brown", pch = 3)

legend("topleft", bty = "n", legend = c( "Extech Body Adj. R sqrd .97; Beta .74", "TVT Adj. R sqrd .7, Beta = .22", "Flir Adj. R sqrd .99, Beta = 1"), pch = c(2,1,3), text.col = c("black","blue", "brown"), bg = "transparent")
abline(tvtBB, col = "blue")
abline(ExBB)
abline(lm(tvt$FLIR.Measurement ~ tvt$Blackbody.Temperature), col = "brown")

#Dahua --------------------------------------------------------------------

#Loading Data
dah = read.csv("/Users/zacharysegal/Downloads/IRT Specs FDA - Dahua.csv")

#Ensuring all data is in range, removing nas, adding column for difference between device and BB
dah = dah[!is.na(dah$Blackbody.Temperature ),]
dah$Dev.Delta = as.numeric(dah$Device.Measurement) - as.numeric(dah$Blackbody.Temperature)
dah = dah[dah$Blackbody.Temperature >= 35 & dah$Blackbody.Temperature <= 40,]

##Comparing Device, Extech on Body Mode, and Flir with BB##
dahBB <- lm(dah$Device.Measurement ~ dah$Blackbody.Temperature)
summary(dahBB)#Adjusted R-squared:  0.9954;  beta   0.76883; p-value  <2e-16 ***

ExBB <- lm(dah$Ex.Body ~ dah$Blackbody.Temperature)
#Adjusted R-squared:  0.9808; beta 0.77974; p-value  < 2e-16 ***

FlirBB <- lm(dah$FLIR.Measurement ~ dah$Blackbody.Temperature)
#Adjusted R-squared:  0.9991; beta  0.998961; p-value  <2e-16 ***

#Comparing Disfference between reading and BB with BB Temperature

DahAc = lm(dah$Dev.Delta ~ dah$Blackbody.Temperature)
#Adjusted R-squared:  0.9513; Beta  -0.23117; p-value <2e-16 ***
DahAc2 = lm(log(dah$Dev.Delta+4) ~ (dah$Blackbody.Temperature));summary(DahAc2)
#not better

FlrAc = lm((dah$FLIR.Measurement-dah$Blackbody.Temperature) ~ dah$Blackbody.Temperature)
#Adjusted R-squared: -0.05132; beta  -0.001039; p-value 0.879

BBAc = lm((dah$Ex.Body-dah$Blackbody.Temperature) ~ dah$Blackbody.Temperature)
#Adjusted R-squared:  0.8013; beta -0.22026; p-value 2.62e-08 ***

#combining plots
par(mfrow=c(1,2))

#Dah vs Ex vs Temp
plot(dah$Blackbody.Temperature, dah$Device.Measurement, pch = 3,
     xlab = "Subject Temperature °C", ylab = "Device Temperature",
     main = "Dahua, Flir, Extech vs Subject Temperature", col = "red")
points(dah$Blackbody.Temperature,dah$Ex.Body, pch = 1, col = "black")
points(dah$Blackbody.Temperature,dah$FLIR.Measurement, pch = 2, col = "brown")
legend(x = 34.2, y = 39.5, bty = "n", y.intersp =.5, cex = .9,
  legend = c( "Extech Body Adj. R sqrd .97; Beta .78", "Flir Adj. R sqrd .99; Beta .77", "Dahua Adj. R sqrd 1; Beta 1"),   pch = c(1,2,3),text.col = c("black","brown", "red"), bg = "transparent")
abline(dahBB, col = "red")
abline(ExBB)
abline(FlirBB, col = "brown")

plot(dah$Blackbody.Temperature, dah$Dev.Delta, ylim = c( -.7, 1.5),
     xlab = "Subject Temperature °C", ylab = "Device Temperature",
     main = "Dahua, Flir, Extech and Subject Difference vs Subject", pch = 3, col = "red")
points(dah$Blackbody.Temperature, c(dah$Ex.Body-dah$Blackbody.Temperature), pch = 1, col = "black")
points(dah$Blackbody.Temperature,c(dah$FLIR.Measurement-dah$Blackbody.Temperature), pch = 2, col = "brown")
legend(x = 36.3, y = 1.6, y.intersp =.5, bty = "n",  pch = c(1,2,3),legend = c( "Extech Body Adj. R sqrd .8; Beta -.22", "Flir Adj. R sqrd 0; Beta 0", "Dahua Adj. R sqrd .95; Beta -.23"), text.col = c("black","brown", "red"), bg = "transparent")
abline(h = 0)
abline(h = 1)
#abline(h = -1)

#residuls
plot(dah$Blackbody.Temperature, DahAc$residuals,
     xlab = "Subject Temperature °C", ylab = "Residual",
     main = "Device ~ Subject Residuals", col = "red", type = "line", ylim = c(-.5,.5))
rect(par("usr")[1],par("usr")[3],par("usr")[2],par("usr")[4], col= rgb(.05,.05,.05,alpha=0.1))
points(dah$Blackbody.Temperature,FlrAc$residuals, col = "brown", type = "line")
points(dah$Blackbody.Temperature,BBAc$residuals, col = "black", type = "line")
#legend("topleft", legend = c( "Extech Body", "Flir",  "Dahua"), text.col = c("black","seagreen","red"), bg = "transparent")
abline(h = 0)

#Hikvision Bullet --------------------------------------------------------------------

#Loading Data
hik = read.csv("/Users/zacharysegal/Downloads/Paper Rob 2.0 - Hik W BB.csv")

#Ensuring all data is in range, removing nas, adding column for difference between device and BB
hik = hik[!is.na(hik$Blackbody.Temperature ),]
hik$Dev.Delta = as.numeric(hik$Device.Measurement) - as.numeric(hik$Blackbody.Temperature)
hik = hik[hik$Blackbody.Temperature >= 35 & hik$Blackbody.Temperature <= 40,]

##Comparing Device, Extech on Body Mode, and Flir with BB##
hikBB <- lm(hik$Device.Measurement ~ hik$Blackbody.Temperature)
summary(hikBB)#Adjusted R-squared:  0.9924;  beta   0.80883; p-value  <2e-16 ***

ExBB <- lm(hik$Ex.Body ~ hik$Blackbody.Temperature); summary(ExBB)
#Adjusted R-squared:  0.9892; beta 0.73221; p-value  < 2e-16 ***

FlirBB <- lm(hik$FLIR.Measurement ~ hik$Blackbody.Temperature); summary(FlirBB)
#Adjusted R-squared:  0.9996; beta  0.996364; p-value  <2e-16 ***

#Comparing Disfference between reading and BB with BB Temperature

hikAc = lm(hik$Dev.Delta ~ hik$Blackbody.Temperature); summary(hikAc)
#Adjusted R-squared:  0.8789; Beta  -0.19117; p-value 2.28e-10 ***

FlrAc = lm((hik$FLIR.Measurement-hik$Blackbody.Temperature) ~ hik$Blackbody.Temperature); summary(FlrAc)
#Adjusted R-squared: -0.01409; beta  -0.003636; p-value 0.406

BBAc = lm((hik$Ex.Body-hik$Blackbody.Temperature) ~ hik$Blackbody.Temperature); summary(BBAc)
#Adjusted R-squared:  0.9244; beta -0.26779; p-value 2.54e-12 ***

#We tested logarithmic models as well, but chose not to include them except for with the meridian because linear regression
#is easier for readers to understand and the relations were barely strengthened
BBAc2 = lm(log(hik$Ex.Body-hik$Blackbody.Temperature +4) ~ hik$Blackbody.Temperature); summary(BBAc2)
#Adjusted R-squared: .94

#combining plots lightseagreen
par(mfrow=c(1,2))

#Hik vs Ex vs Temp
plot(hik$Blackbody.Temperature, hik$Device.Measurement,
     xlab = "Subject Temperature °C", ylab = "Device Temperature",
     main = "Hikvision, Flir, Extech vs Subject Temperature", col = "lightseagreen", pch = 2)
points(hik$Blackbody.Temperature,hik$Ex.Body, col = "black", pch = 1)
points(hik$Blackbody.Temperature,hik$FLIR.Measurement, col = "brown", pch = 3)
legend(x = 34, y = 39.5, bty = "n",y.intersp =.5, cex = .9,
      legend = c( "Extech Body Adj. R sqrd .92; Beta -.27", "Hikvision Adj. R sqrd .99; Beta .8", "Flir Adj. R sqrd 1; Beta 1"), text.col = c("black","lightseagreen", " brown"), pch = c(1, 2, 3),bg = "transparent")
abline(hikBB, col = "lightseagreen")
abline(ExBB)
abline(FlirBB, col = "brown")

#accuracy
plot(hik$Blackbody.Temperature, c(hik$Device.Measurement - hik$Blackbody.Temperature),
     xlab = "Subject Temperature °C", ylab = "Device Temperature", ylim = c(-.6, 2),
     main = "Hikvision, Flir, Extech Difference from Subject vs Subject", col = "lightseagreen", pch = 2)
points(hik$Blackbody.Temperature,c(hik$Ex.Body- hik$Blackbody.Temperature), col = "black", pch = 1)
points(hik$Blackbody.Temperature,c(hik$FLIR.Measurement- hik$Blackbody.Temperature), col = "brown" , pch = 3)
legend(x = 35.2, y = 2, bty = "n", y.intersp =.5,
       legend = c( "Extech Body Adj. R sqrd .99 ; Beta .73", "Hikvision Adj. R sqrd .88; Beta -.19", "Flir Adj. R sqrd 0; Beta 0"), pch = c(1,2,3),text.col = c("black","lightseagreen", "brown"), bg = "transparent")
abline(h = 1)
abline(h = 0)

#residuls
plot(hik$Blackbody.Temperature,hikAc$residuals,
     xlab = "Black Body Temperature °C", ylab = "Residual",
     main = "Device ~ BB Residuals", col = "lightseagreen", type = "line", ylim = c(-.5,.5))
rect(par("usr")[1],par("usr")[3],par("usr")[2],par("usr")[4], col= rgb(.05,.05,.05,alpha=0.1))
points(hik$Blackbody.Temperature,FlrAc$residuals, col = "brown", type = "line")
points(hik$Blackbody.Temperature,BBAc$residuals, col = "black", type = "line")
#legend("topleft", legend = c( "Extech Body", "Flir",  "Hikvision"), text.col = c("black","Green","lightseagreen"), bg = "transparent")
abline(h = 0)

#Certify --------------------------------------------------------------------

#Loading Data
cert = read.csv("/Users/zacharysegal/Downloads/Paper Rob 2.0 - Certify (Telpo OEM) Tablet.csv")

#Ensuring all data is in range, adding column for difference between device and BB
cert = cert[cert$Blackbody.Temperature >= 35 & cert$Blackbody.Temperature <= 40,]
cert$Dev.Delta = as.numeric(cert$Device.Measurement) - as.numeric(cert$Blackbody.Temperature)

##Comparing Device Deviation from BB and BB##
#Making a linear model to compare Device Deviation from BB and BB
certAc = lm(cert$Dev.Delta~cert$Blackbody.Temperature); summary(certAc)
# Adjusted R-squared:   0.9113; beta  -0.47065; p-value 1.17e-11 ***
certAc2 = lm(log(cert$Dev.Delta+4)~cert$Blackbody.Temperature); summary(certAc2)
#.9446

##Comparing Device, Extech on Body Mode, and BB##
certBB <- lm(cert$Device.Measurement ~ cert$Blackbody.Temperature); summary(certBB)
#Adjusted R-squared:  0.9286; Beta  0.52935; p-value  1.48e-12 ***

ExBB <- lm(cert$Ex.Body ~ cert$Blackbody.Temperature); summary(ExBB)
#Adjusted R-squared:  0.9739; beta 0.75688; p-value < 2e-16 ***

#Plot
#side-by-side plots
par(mfrow = c(1,2))

plot(cert$Blackbody.Temperature, cert$Device.Measurement,
     xlab = "Subject Temperature °C", ylab = "Device Temperature",
     main = "Certify, Flir, Extech vs Subject Temperature",
     ylim=c(34.5, 42.5), col = "deeppink", pch =1)
points(cert$Blackbody.Temperature,cert$Ex.Body, col = "black" , pch = 2)
points(cert$Blackbody.Temperature,cert$FLIR.Measurement, col = "brown", pch = 3)
legend("topleft",bty = "n", pch = c(2,1,3), legend = c( "Extech Body Adj. R sqrd .97; Beta .76", " Certify Adj. R sqrd .93; Beta .53", "Flir Adj. R sqrd .99; Beta 1"), text.col = c("black","deeppink", "brown"), bg = "transparent")
abline(certBB, col = "deeppink")
abline(ExBB)
abline(lm(cert$FLIR.Measurement ~ cert$Blackbody.Temperature), col = "brown")

plot(cert$Blackbody.Temperature, cert$Dev.Delta,
     xlab = "Subject Temperature °C", ylab = "Difference",
     main = "Difference Between Device and Subject\nvs Subject Temperature",
     ylim=c(-2, 2), col = "deeppink", pch =1)
points(cert$Blackbody.Temperature,c(cert$Ex.Body-cert$Blackbody.Temperature), col = "black", pch = 2)
points(cert$Blackbody.Temperature,c(cert$FLIR.Measurement-cert$Blackbody.Temperature), col = "brown", pch = 3)
abline(h = 1)
abline(h = -1)
abline(h = 0)

#ZKTeco --------------------------------------------------------------------

#Loading Data
zk = read.csv("/Users/zacharysegal/Downloads/Paper Rob 2.0 - ZKTeco 8_ Tablet.csv")

#Ensuring all data is in range, adding column for difference between device and BB
zk = zk[zk$Blackbody.Temperature >= 35 & zk$Blackbody.Temperature <= 40,]
zk$Dev.Delta = as.numeric(zk$Device.Measurement) - as.numeric(zk$Blackbody.Temperature)

##Comparing Device Deviation from BB and BB##
#Making a linear model to compare Device Deviation from BB and BB
zkAC = lm(zk$Dev.Delta~zk$Blackbody.Temperature); summary(zkAC)
# Adjusted R-squared:   0.8889; beta  -0.42182; p-value 1.00e-10 ***

##Comparing Device, Extech on Body Mode, and BB##
zkBB <- lm(zk$Device.Measurement ~ zk$Blackbody.Temperature); summary(zkBB)
#Adjusted R-squared:  0.9378; Beta  0.57818; p-value  3.96e-13 ***
zkBB2 <- lm((zk$Device.Measurement) ~ log(zk$Blackbody.Temperature)); summary(zkBB2)
#not better

ExBB <- lm(zk$Ex.Body ~ zk$Blackbody.Temperature); summary(ExBB)
#Adjusted R-squared:  0.9806; beta 0.76545; p-value < 2e-16 ***

#Plot
#side-by-side plots
par(mfrow = c(1,2))

plot(zk$Blackbody.Temperature, zk$Device.Measurement,
     xlab = "Subject Temperature °C", ylab = "Device Temperature",
     main = "ZKTeco, Flir, Extech vs Subject Temperature",
     ylim=c(34.5, 42.5), col = "darkgoldenrod", pch = 1)
points(zk$Blackbody.Temperature,zk$Ex.Body, col = "black", pch = 2)
points(zk$Blackbody.Temperature,zk$FLIR.Measurement, col = "brown", pch = 3)
legend("topleft",bty = "n", pch = c(2,1,3),legend = c( "Extech Body Adj. R sqrd .98; Beta .77", " ZKTeco Adj. R sqrd .94; Beta .58", "Flir Adj. R sqrd .99; Beta 1"), text.col = c("black","darkgoldenrod", "brown"), bg = "transparent")
abline(zkBB, col = "darkgoldenrod")
abline(ExBB)
abline(lm(zk$FLIR.Measurement ~ zk$Blackbody.Temperature), col = "brown")

plot(zk$Blackbody.Temperature, zk$Dev.Delta,
     xlab = "Subject Temperature °C", ylab = "Difference",
     main = "Difference Between Device and Subject\nvs Subject Temperature",
     ylim=c(-1.5, 1.6), col = "darkgoldenrod", pch = 1)
points(zk$Blackbody.Temperature,c(zk$Ex.Body-zk$Blackbody.Temperature), col = "black", pch = 2)
points(zk$Blackbody.Temperature,c(zk$FLIR.Measurement-zk$Blackbody.Temperature), col = "brown", pch = 3)
abline(h = 1)
abline(h = -1)
#points(c(36.5,40.5), c(-1,-1), type = "line")
#legend(34.5, -.8,bty = "n", legend = c( "Extech Body", "ZKTeco"), text.col = c("black","darkgoldenrod"), bg = "transparent")
abline(h = 0)

#Meridian 2.0 --------------------------------------------------------------------

#Loading Data
md = read.csv("/Users/zacharysegal/Downloads/meridian.csv")

#Ensuring all data is in range, adding column for difference between device and BB
md = md[md$Blackbody.Temperature >= 35 & md$Blackbody.Temperature <= 40,]
md$Dev.Delta = as.numeric(md$Device.Measurement) - as.numeric(md$Blackbody.Temperature)
md$logdev = log(md$Device.Measurement)
md$logbb = log(md$Blackbody.Temperature)
md$exdev = 2^(md$Device.Measurement)
md$exbb = 2^(md$Blackbody.Temperature)

##Comparing Device Deviation from BB and BB##
#Making a linear model to compare Device Deviation from BB and BB
mdAC = lm(md$Dev.Delta~md$Blackbody.Temperature); summary(mdAC)
# Adjusted R-squared:   0.8158; beta  -0.40104; p-value 1.27e-08 ***
mdlogAC = lm(md$logdev~md$Blackbody.Temperature); summary(mdlogAC)
# Adjusted R-squared:   0.9126; beta  0.015740; p-value 1.02e-11 ***

er = lm(md$Dev.Delta~md$Blackbody.Temperature); summary(er)

##Comparing Device, Extech on Body Mode, and BB##
mdBB <- lm(md$Device.Measurement ~ md$Blackbody.Temperature); summary(mdBB)
#Adjusted R-squared:  0.9086; Beta  0.59896; p-value  1.56e-11 ***

ExBB <- lm(md$Ex.Body ~ md$Blackbody.Temperature); summary(ExBB)
#Adjusted R-squared:  .9814; beta 0.73688; p-value < 2e-16 ***

#restricted to below 36.5
md37 = md[md$Blackbody.Temperature >= 35 & md$Blackbody.Temperature <= 36.25,]

md37BB <- lm(md37$Device.Measurement ~ md37$Blackbody.Temperature); summary(md37BB)
#Adjusted R-squared:  0.3902; beta <.0001; p-value 0.158
mean(md37$Device.Measurement) #36.9

#Plot  darkgoldenrod
#side-by-side plots
par(mfrow = c(1,2))

plot(md$Blackbody.Temperature, md$Device.Measurement,
     xlab = "Subject Temperature °C", ylab = "Device Temperature",
     main = "Meridian, Flir, Extech vs Subject Temperature",
     ylim=c(34.5, 42.5), col = "orange", pch = 1)
points(md$Blackbody.Temperature,md$Ex.Body, col = "black", pch =2)
points(md$Blackbody.Temperature,md$FLIR.Measurement, col = "brown", pch = 3)
legend("topleft",bty = "n", legend = c( "Extech Body Adj. R sqrd .98; Beta .74", " Meridian Adj. R sqrd .91; Beta .6", "Flir Adj. R sqrd .99; Beta 1"),
      pch = c(2,1,3) ,text.col = c("black","orange", "brown"), bg = "transparent")
abline(mdBB, col = "orange")
abline(ExBB)
abline(lm(md$FLIR.Measurement ~ md$Blackbody.Temperature), col = "brown")

plot(md$Blackbody.Temperature, md$Dev.Delta,
     xlab = "Subject Temperature °C", ylab = "Difference",
     main = "Difference Between Device and Subject\nvs Subject Temperature",
     ylim=c(-1, 2), col = "orange", pch = 1)
points(md$Blackbody.Temperature,c(md$Ex.Body-md$Blackbody.Temperature), col = "black", pch = 2)
points(md$Blackbody.Temperature,c(md$FLIR.Measurement-md$Blackbody.Temperature), col = "brown", pch = 3)
abline(h = 1)
abline(h = -1)
abline(h = 0)

# Combined Devices, Controls, Other Figures --------------------------------------------------------------------

# Key --------------------------------------------------------------------
#BB is the Black Body we used as a target for testing
#Ex represents Extech on body mode unless otherwise specified; Black
#Surf represents Extech on Surface Mode
#FLir/flir represents Flir IRT; Brown
#Bems/bems/bem/b all represent the Bems IRT; Purple
#TVT/tvt/t all represent TVT IRT; Blue
#Dahua/Dah/dah/d represent Dahua IRT; Red
#Cert/cert/c represetns Certify IRT; deeppink
#Zk/zk/Z/z represetns ZKTeco IRT; darkgoldenrod
#Hik/hik/h/H represents Hikvision IRT; lightseagreen
#md/Md/m/m represents Meridian IRT; orange

# NCITs and FLIR ----------------------------------------------------------

#combining data of all 4 sessions including unused Meridian data; 35°C - 40°C
CMBData = data.frame("BB" = bems[bems$Blackbody.Temperature >= 35,]$Blackbody.Temperature,
                     "FlirB" = bems[bems$Blackbody.Temperature >= 35,]$FLIR.Measurement,"ExB" = bems[bems$Blackbody.Temperature >= 35,]$Ex.Body,"SurfB" = bems[bems$Blackbody.Temperature >= 35,]$Ex.Surface,
                     "FlirT" = tvt[tvt$Blackbody.Temperature >= 35,]$FLIR.Measurement,"ExT" = tvt[tvt$Blackbody.Temperature >= 35,]$Ex.Body,"Surft" = tvt[tvt$Blackbody.Temperature >= 35,]$Ex.Surface,
                     "FlirD" = dah[dah$Blackbody.Temperature >= 35 & dah$Blackbody.Temperature <=40,]$FLIR.Measurement,"ExD" = dah[dah$Blackbody.Temperature >= 35 & dah$Blackbody.Temperature <=40,]$Ex.Body,"Surfd" = dah[dah$Blackbody.Temperature >= 35,]$Ex.Surface,
                     "FlirM" = md[md$Blackbody.Temperature >= 35 & md$Blackbody.Temperature <=40,]$FLIR.Measurement,"ExM" = md[md$Blackbody.Temperature >= 35 & md$Blackbody.Temperature <=40,]$Ex.Body, "Surfm" = md[md$Blackbody.Temperature >= 35,]$Ex.Surface,
                     "FlirC" = cert[cert$Blackbody.Temperature >= 35 & cert$Blackbody.Temperature <=40,]$FLIR.Measurement,"ExC" = cert[cert$Blackbody.Temperature >= 35 & cert$Blackbody.Temperature <=40,]$Ex.Body, "Surfc" = cert[cert$Blackbody.Temperature >= 35,]$Ex.Surface,
                     "FlirZ" = zk[zk$Blackbody.Temperature >= 35 & zk$Blackbody.Temperature <=40,]$FLIR.Measurement,"ExZ" = zk[zk$Blackbody.Temperature >= 35 & zk$Blackbody.Temperature <=40,]$Ex.Body, "Surfz" = zk[zk$Blackbody.Temperature >= 35,]$Ex.Surface,
                     "FlirH" = hik[hik$Blackbody.Temperature >= 35 & hik$Blackbody.Temperature <=40,]$FLIR.Measurement,"ExH" = hik[hik$Blackbody.Temperature >= 35 & hik$Blackbody.Temperature <=40,]$Ex.Body, "Surfh" = hik[hik$Blackbody.Temperature >= 35,]$Ex.Surface
                     )

#list of relevant columns for each device
flirs = c("FlirB", "FlirT", "FlirD", "FlirM", "FlirH","FlirZ","FlirC")
Exs = c("ExB","ExT","ExD","ExM","ExH","ExZ","ExC")
Surf = c("SurfB","Surft","Surfd","Surfm", "Surfh","Surfz","Surfc")

#function to find max difference between device and BB temperature
#n = columns to go over, lengthy length of relevant df, frame = df with data, indx = column to compare too - BB in this case
maxy = function(n, lengthy, frame, indx){
  mx = 0

  #go over columns
  for (c in n){

    #go over every row
    i = 0
    while(i < lengthy){
      i= i + 1
      dif = (frame[i, indx]-frame[i,c])^2
      if(mx < dif ){mx = dif}}}
  mx = mx^(.5); print(mx)}

#max difference between device and BB in any round
maxy(n = flirs, lengthy = length(CMBData$BB),frame =  CMBData,indx =  "BB") #.15
maxy(Exs,length(CMBData$BB), CMBData,"BB") #1.8
maxy(Surf,length(CMBData$BB), CMBData,"BB") #.1

#isolating flir, extech body, and extech surface data into individual dfs
cmbflir = CMBData[flirs]
cmbex = CMBData[Exs]
cmsurf = CMBData[Surf]

#inner class dif
cmbflir$max = apply(cmbflir, 1, function(x) diff(range(x))); max(cmbflir$max) #.2
cmbex$max = apply(cmbex, 1, function(x) diff(range(x))); max(cmbex$max) #.6
cmsurf$max = apply(cmsurf, 1, function(x) diff(range(x))); max(cmsurf$max) #.2

#Plot

#graphing 3 plots at once
par(mfrow = c(1,1))

#Extech body
plot(CMBData$BB, CMBData$ExB, pch = 1,col = "purple", cex = 1.2, xlab = "Subject Temperature °C", ylab = "Extech Reading, Body Mode °C", main = "Extech Body")
points(CMBData$BB, CMBData$ExM, pch = 2,col ="orange ")
points(CMBData$BB, CMBData$ExD, pch = 3,col = "red")
points(CMBData$BB, CMBData$ExT, pch = 4,col = "blue")
points(CMBData$BB, CMBData$ExZ, pch = 5,col ="darkgoldenrod ")
points(CMBData$BB, CMBData$ExC, pch = 6,col = "deeppink")
points(CMBData$BB, CMBData$ExH, pch = 7,col = "lightseagreen")
legend(bty = "n", cex = 1.2, x = 34, y = 40.5, legend = c( "Each Color/Shape Corresponds to \na Different Round of Testing"), text.col = c("black","green"), bg = "transparent")
#text(39.1,38.3, "Largest Extra-Round\nDifference .45°C")
abline(coef = c(0,1))

#Extech surf
plot(CMBData$BB, pch = 1,CMBData$SurfB, col = "purple", xlab = "Subject Temperature °C", ylab = "Extech Reading, Surface Mode °C", main = "Extech Surface")
points(CMBData$BB, pch = 2,CMBData$Surfm, col ="orange ")
points(CMBData$BB, pch = 3,CMBData$Surfd, col = "red")
points(CMBData$BB, pch = 4,CMBData$Surft, col = "blue")
points(CMBData$BB, pch = 5,CMBData$Surfz, col ="darkgoldenrod ")
points(CMBData$BB, pch = 6,CMBData$Surfc, col = "deeppink")
points(CMBData$BB, pch = 7,CMBData$Surfh, col = "lightseagreen")
#legend(bty = "n", "topleft", legend = c( "Each Color Corresponds to\na Different Round of Testing"), text.col = c("black","green"), bg = "transparent")
#text(39.1,38, "Largest Extra-Round\nDifference .2°C")
abline(coef = c(0,1))

#Flir Round to Round
plot(CMBData$BB, pch = 1,CMBData$FlirB, col = "purple", xlab = "Subject Temperature °C",
     ylab = "Flir Reading °C", main = "Flir IRT")
points(CMBData$BB, pch = 2,CMBData$FlirM, col ="orange", pch = ".")
points(CMBData$BB, pch = 3,CMBData$FlirD, col = "red", pch = "x")
points(CMBData$BB, pch = 4,CMBData$FlirT, col = "blue", pch = "f")
points(CMBData$BB, pch = 5,CMBData$FlirZ, col ="darkgoldenrod ")
points(CMBData$BB, pch = 6,CMBData$FlirC, col = "deeppink")
points(CMBData$BB, pch = 7,CMBData$FlirH, col = "lightseagreen")
#legend(bty = "n", "topleft", legend = c( "Each Color/Shape Corresponds to\na Different Round of Testing"), text.col = c("black","green"), bg = "transparent")
#text(38.9,37.6, "Largest Extra-Round\nDifference .2°C")
abline(coef = c(0,1))

# Combine --------------------------------------------------------------------
# Key --------------------------------------------------------------------
#BB is the Black Body we used as a target for testing
#Ex represents Extech on body mode unless otherwise specified; Black
#Surf represents Extech on Surface Mode
#FLir/flir represents Flir IRT; Brown
#Bems/bems/bem/b all represent the Bems IRT; Purple
#TVT/tvt/t all represent TVT IRT; Blue
#Dahua/Dah/dah/d represent Dahua IRT; Red
#Cert/cert/c represetns Certify IRT; deeppink
#Zk/zk/Z/z represetns ZKTeco IRT; darkgoldenrod
#Hik/hik/h/H represents Hikvision IRT; lightseagreen
#md/Md/m/m represents Meridian IRT; orange

#combine device data
full = data.frame("BB" = bems$Blackbody.Temperature,"bems" = bems$Device.Measurement,
                  "tvt" = tvt$Device.Measurement, "cert" = cert$Device.Measurement, "hik" = hik$Device.Measurement
                , "dah" = dah$Device.Measurement, "zk" = zk$Device.Measurement, "md" = md$Device.Measurement)

#average all the tested temperatures
averaged  = apply(full[,2:7], 1, function(x) mean(x))

#take out the TVT and Bems
averagedwo  = apply(full[,4:7], 1, function(x) mean(x))

#average the controls
exbod = apply(cmbex[,1:7], 1, function(x) mean(x))
exsurf = apply(cmsurf[,1:7], 1, function(x) mean(x))
flrs = apply(cmbflir[,1:7], 1, function(x) mean(x))

#add to combines df
full$averaged = averaged
full$exbod = exbod
full$averagedwo = averagedwo
full$flrs = flrs

#plot data
plot(bems$Blackbody.Temperature, full$flrs, col = "brown" ,type = "l", lty =1,
     xlab = "Subject Temperature °C", ylab = "Temperature °C", main = "Tested IRTs vs. Subject Temperature",
     xlim =c(35, 40.5))
points(bems$Blackbody.Temperature, bems$Device.Measurement, type = "l", col = "purple", lty = 2)
points(hik$Blackbody.Temperature, hik$Device.Measurement, type = "l", col = "lightseagreen", lty = 3)
points(bems$Blackbody.Temperature, dah$Device.Measurement, type = "l",col = "red", lty = 4)
points(bems$Blackbody.Temperature, zk$Device.Measurement, type = "l", col = "darkgoldenrod", lty = 5)
points(bems$Blackbody.Temperature, tvt$Device.Measurement, type = "l", col = "blue", lty = 6)
points(bems$Blackbody.Temperature, cert$Device.Measurement, type = "l", col = "deeppink", lty = 7)
points(bems$Blackbody.Temperature, md$Device.Measurement, type = "l", col = "orange", lty = 8)
text(x = c(rep(40,8)),
     y = c(c(full[21,c(12,8,6,5,3,2)])),
     labels = c("Avg. Flir", "Meridian", "Dahua", "Hikvision",  "TVT", "Bems"),
     col = c("Brown","orange","red", "lightseagreen",  "blue", "Purple"),
     pos = 4)
text(x = c(rep(40,2)),
     y = c(full[21,4] - c(-.07,.07)),
     labels = c("ZkTeco", "Certify"),
     col = c("darkgoldenrod", "deeppink"),
     pos = 4)

plot(full$BB,full$BB,ylim = c(-3.1,2.25), col = "black" ,type = "l",
     xlab = "Subject Temperature °C", ylab = "Device - Subject",
     main = "Combined IRTs and Flir Difference from Subject", xlim =c(35, 40.85), lty = 2)
abline(h = -1, col = "black", lty = 1)
abline(h = 1, col = "black", lty = 1)
abline(h = 0, col = "black", lty = 1, cex = 2.1)
points(bems$Blackbody.Temperature, (bems$FLIR.Measurement - bems$Blackbody.Temperature), type = "l", col = "brown", lty = 3)
points(bems$Blackbody.Temperature, (full$exbod - bems$Blackbody.Temperature), type = "l", col = "black", lty = 4)
points(bems$Blackbody.Temperature, bems$Dev.Delta, type = "l", col = "purple", lty = 5)
points(hik$Blackbody.Temperature, hik$Dev.Delta, type = "l", col = "lightseagreen", lty = 6)
points(bems$Blackbody.Temperature, dah$Dev.Delta, type = "l",col = "red", lty = 7)
points(bems$Blackbody.Temperature, zk$Dev.Delta, type = "l", col = "darkgoldenrod", lty = 8)
points(bems$Blackbody.Temperature, tvt$Dev.Delta, type = "l", col = "blue", lty = 9)
points(bems$Blackbody.Temperature, cert$Dev.Delta, type = "l", col = "deeppink", lty = 10)
points(bems$Blackbody.Temperature, md$Dev.Delta, type = "l", col = "orange", lty = 11)
text(x = c(rep(40,8)),
     y = c(c(full[21,c(12,8,6,5,3,2)]- c(39.94, rep(40,5)))),
     labels = c("Flir", "Meridian", "Dahua", "Hikvision",  "TVT", "Bems"),
     col = c("Brown","orange","red", "lightseagreen",  "blue", "Purple"),
     pos = 4)
text(x = c(rep(40,2)),
     y = c(c(-.92,-1.08)),
     labels = c("ZkTeco", "Certify"),
     col = c("darkgoldenrod", "deeppink"),
     pos = 4)
text(y = full[21,"exbod"] - 39.7,
     x = 40,
     labels = c("Extech Body"),
     col = c("black"),
     pos = 4)

#abs
plot(full$BB,full$BB,ylim = c(0,3.2), col = "black" ,type = "l",
     xlab = "Subject Temperature °C", ylab = "abs(Device - Subject)",
     main = "Combined IRTs and Flir Difference from Subject", xlim =c(35, 40.5), lty = 2)
abline(v = 37, col = "black", lty = 1)
points(bems$Blackbody.Temperature, abs(bems$FLIR.Measurement - bems$Blackbody.Temperature), type = "l", col = "brown", lty = 3)
points(bems$Blackbody.Temperature, abs(bems$Dev.Delta), type = "l", col = "purple", lty = 4)
points(hik$Blackbody.Temperature, abs(hik$Dev.Delta), type = "l", col = "lightseagreen", lty = 5)
points(bems$Blackbody.Temperature, abs(dah$Dev.Delta), type = "l",col = "red", lty = 6)
points(bems$Blackbody.Temperature, abs(zk$Dev.Delta), type = "l", col = "darkgoldenrod", lty = 7)
points(bems$Blackbody.Temperature, abs(tvt$Dev.Delta), type = "l", col = "blue", lty = 8)
points(bems$Blackbody.Temperature, abs(cert$Dev.Delta), type = "l", col = "deeppink", lty = 9)
points(bems$Blackbody.Temperature, abs(md$Dev.Delta), type = "l", col = "orange", lty = 10)
points(bems$Blackbody.Temperature, abs(full$exbod-full$BB), type = "l", col = "black", lty = 11)
text(x = c(rep(40,8)),
     y = c(c(40-full[21,c(12,8,6,5,3,2)])),
     labels = c("Flir", "Meridian", "Dahua", "Hikvision",  "TVT", "Bems"),
     col = c("Brown","orange","red", "lightseagreen",  "blue", "Purple"),
     pos = 4)
text(x = c(rep(40,2)),
     y = c(c(.93,1.07)),
     labels = c("ZkTeco", "Certify"),
     col = c("darkgoldenrod", "deeppink"),
     pos = 4)
text(y = full[21,"exbod"] - 39.93,
     x = 40,
     labels = c("Extech Body"),
     col = c("black"),
     pos = 4)

# Averaged --------------------------------------------------------------------

plot(full$BB, c(averaged-full$BB), col = 2, type = "l", ylim = c(-1.5, 2), xlab = "Subject Temperature °C", ylab = "Device - Subject",
     main = "Difference of Averaged Devices and Extech on Body Mode\nvs. Subject Temperature")
points(full$BB, c(averagedwo-full$BB), col = 3, type = "l", lty = 2)
points(full$BB, c(exbod-full$BB), col = 1, type = "l", lty = 3)
abline(h = 0, lty = 2)
legend(x = 36.5, y = 2.2, text.width = .2,bty = "n",
       legend = c("Average of Extech on Body Mode", "Average of Tested Devices", "Average of Tested Devices W/O Bems, TVT"),
       text.col = c(1,2,3), y.intersp =.5, cex = .9  )

#abs

plot(full$BB, abs(averaged-full$BB), col = 2, type = "l", ylim = c(0, 2), xlab = "Subject Temperature °C", ylab = "Abs(Device - Subject)",
     main = "Absolute Value of\nAveraged Device Subject Difference")
points(full$BB, abs(averagedwo-full$BB), col = 3, type = "l", lty = 2)
points(full$BB, abs(exbod-full$BB), col = 1, type = "l", lty = 3)
legend(x = 35.5, y = 2, text.width = .2,bty = "n",
       legend = c("Average of Extech on Body Mode", "Average of Tested Devices", "Average of Tested Devices W/O Bems, TVT"),
       text.col = c(1,2,3), y.intersp =.5, cex = 1.1  )

# Bland-Altman --------------------------------------------------------------------
#A function to make plotting easier
#x is device 1, y is device 2
AltMan = function(x,y,w = "x"){
  bl = blandr.statistics(x, y)
  mn = bl$means
  dif = bl$differences

  #the x-axis
  if(w == "x"){ return(mn)}

  #the y axis
  else if(w == "y"){return(dif)}
  else{
    #draw the lines to create the plot
    abline(h = 0)
    abline(h = bl$bias, lty = 2)
    abline(h = bl$biasUpperCI, lty = 2)
    abline(h =  bl$biasLowerCI, lty = 2)
    }
}

#Bems
bl = blandr.statistics(full$bems, full$BB)
blm = lm(bl$differences ~ bl$means); summary(blm)$r.squared; blm$coefficients[2]

plot(AltMan(full$bems, full$BB, "x"),AltMan(full$bems, full$BB, "y"),
             main = "Bland-Altman plot of Bems,\nExtech on Body, and Flir vs. Subject Temp",
             col = "purple", ylab = "Differences", xlab = "Means", pch =1)
points(AltMan(full$exbod, full$BB, "x"),AltMan(full$exbod, full$BB, "y"), pch = 2 )
points(AltMan(full$flrs, full$BB, "x"),AltMan(full$flrs, full$BB, "y"), col = "brown", pch = 3)
AltMan(full$bems, full$BB, "u")
abline(blm, col = "purple")
text(pos = 3, col = "purple", x = c(bl$means[15]-1.2, bl$means[15] - .95), y  = c(bl$differences[18]+ .81,bl$differences[18] +.81),
     labels = c("R-Squared ","0.99") )
text(pos = 3, col = "purple",x = c(bl$means[15]-1.2, bl$means[15] - .95), y  = c(bl$differences[18]+ .6,bl$differences[18] +.6),
     labels = c("Beta ", "-1.979") )
legend(x = 35.5, y = -1.8, bty = "n", ncol = 1, y.intersp = .5,
       legend = c("Bems", "Extech", "Flir"), text.col = c("Purple", "Black", "Brown"), pch = c(1,2,3))

#TVT
bl = blandr.statistics(full$tvt, full$BB)
bl$blm = lm(bl$differences ~ bl$means); summary(blm)$r.squared; blm$coefficients[2]

plot(AltMan(full$tvt, full$BB, "x"),AltMan(full$tvt, full$BB, "y"),
     main = "Bland-Altman plot of TVT,\nExtech on Body, and Flir vs. Subject Temp",
     col = "Blue", xlab = "Means", ylab = "Differences", pch = 1)
points(AltMan(full$exbod, full$BB, "x"),AltMan(full$exbod, full$BB, "y"), pch = 2)
points(AltMan(full$flrs, full$BB, "x"),AltMan(full$flrs, full$BB, "y"), col = "brown", pch = 3)
AltMan(full$tvt, full$BB, "u")
abline(blm, col = "Blue")
text(pos = 3, col = "Blue", x = c(bl$means[18], bl$means[18] + .4), y  = c(bl$differences[18]+ .8,bl$differences[18] +.8),
     labels = c("R-Squared ","0.92") )
text(pos = 3, col = "Blue",x = c(bl$means[18], bl$means[18] + .4), y  = c(bl$differences[18]+ .6,bl$differences[18] +.6),
     labels = c("Beta ", "-1.242") )
legend(#x = 35.5, y = -2,
       "bottomleft", bty = "n", ncol = 1, y.intersp = .5,
       legend = c("TVT", "Extech", "Flir"), text.col = c("Blue", "Black", "Brown"), pch = c(1,2,3))

#Dahua

bl = blandr.statistics(full$dah, full$BB)
blm = lm(bl$differences ~ bl$means); summary(blm)$r.squared; blm$coefficients[2]

plot(AltMan(full$dah, full$BB, "x"),AltMan(full$dah, full$BB, "y"), pch = 1,
     main = "Bland-Altman plot of Dahua,\nExtech on Body, and Flir vs. Subject Temp",
     col = "Red", xlab = "Means", ylab = "Differences", ylim = c(-.6, 1))
points(AltMan(full$exbod, full$BB, "x"),AltMan(full$exbod, full$BB, "y"), pch = 2)
points(AltMan(full$flrs, full$BB, "x"),AltMan(full$flrs, full$BB, "y"), col = "brown", pch = 3)
AltMan(full$dah, full$BB, "u")
abline(blm, col = "Red")
text(pos = 3, col = "Red", x = c(bl$means[8], bl$means[8] + .4), y  = c(bl$differences[18]+ .95,bl$differences[18] +.95),
     labels = c("R-Squared ","0.94") )
text(pos = 3, col = "Red",x = c(bl$means[8], bl$means[8] + .4), y  = c(bl$differences[18] + .89,bl$differences[18]+ .89),
     labels = c("Beta ", "-0.256") )
legend(#x = 35.5, y = -2,
  "bottomleft", bty = "n", ncol = 1, y.intersp = .5,
  legend = c("Dahua", "Extech", "Flir"), text.col = c("Red", "Black", "Brown"), pch = c(1,2,3))

#Cert/cert/c represetns Certify IRT; deeppink
bl = blandr.statistics(full$cert, full$BB)
blm = lm(bl$differences ~ bl$means); summary(blm)$r.squared; blm$coefficients[2]

plot(AltMan(full$cert, full$BB, "x"),AltMan(full$cert, full$BB, "y"),
     main = "Bland-Altman plot of Certify,\nExtech on Body, and Flir vs. Subject Temp",
     col = "deeppink", xlab = "Means", ylab = "Differences", pch = 1)
points(AltMan(full$exbod, full$BB, "x"),AltMan(full$exbod, full$BB, "y"), pch = 2 )
points(AltMan(full$flrs, full$BB, "x"),AltMan(full$flrs, full$BB, "y"), col = "brown", pch = 3)
AltMan(full$cert, full$BB, "u")
abline(blm, col = "deeppink")
text(pos = 3, col = "deeppink", x = c(bl$means[8]+.3 , bl$means[8] + .65), y  = c(bl$differences[18]+ .1,bl$differences[18] +.1),
     labels = c("R-Squared ","0.857") )
text(pos = 3, col = "deeppink",x = c(bl$means[8] +.3 , bl$means[8] + .65), y  = c(bl$differences[18] ,bl$differences[18]),
     labels = c("Beta ", "-0.593") )
legend(#x = 35.5, y = -2,
  "bottomleft", bty = "n", ncol = 1, y.intersp = 1, x.intersp=.5,
  legend = c("Certify", "Extech", "Flir"), text.col = c("deeppink", "Black", "Brown"), pch = c(1,2,3))

#Zk/zk/Z/z represetns ZKTeco IRT; darkgoldenrod
bl = blandr.statistics(full$zk, full$BB)
blm = lm(bl$differences ~ bl$means); summary(blm)$r.squared; blm$coefficients[2]

plot(AltMan(full$zk, full$BB, "x"),AltMan(full$zk, full$BB, "y"), pch = 1,
     main = "Bland-Altman plot of ZKTeco,\nExtech on Body, and Flir vs. Subject Temp",
     col = "darkgoldenrod", xlab = "Means", ylab = "Differences", )
points(AltMan(full$exbod, full$BB, "x"),AltMan(full$exbod, full$BB, "y"), pch = 2)
points(AltMan(full$flrs, full$BB, "x"),AltMan(full$flrs, full$BB, "y"), col = "brown", pch = 3)
AltMan(full$zk, full$BB, "u")
abline(blm, col = "darkgoldenrod")
text(pos = 3, col = "darkgoldenrod", x = c(bl$means[8] +.3, bl$means[8] + .65), y  = c(bl$differences[18]+ .1,bl$differences[18] +.1),
     labels = c("R-Squared ","0.832") )
text(pos = 3, col = "darkgoldenrod",x = c(bl$means[8] +.3, bl$means[8] + .65), y  = c(bl$differences[18] ,bl$differences[18]),
     labels = c("Beta ", "-0.513") )
legend(#x = 35.5, y = -2,
  "bottomleft", bty = "n", ncol = 1, y.intersp = .5, x.intersp = .5,
  legend = c("ZKTeco", "Extech", "Flir"), text.col = c("darkgoldenrod", "Black", "Brown"), pch = c(1,2,3))

#Hik/hik/h/H represents Hikvision IRT; lightseagreen
bl = blandr.statistics(full$hik, full$BB)
blm = lm(bl$differences ~ bl$means); summary(blm)$r.squared; blm$coefficients[2]

plot(AltMan(full$hik, full$BB, "x"),AltMan(full$hik, full$BB, "y"),
     main = "Bland-Altman plot of Hikvision,\nExtech on Body, and Flir vs. Subject Temp",
     col = "lightseagreen", xlab = "Means", ylab = "Differences", ylim = c(-.6, 1))
points(AltMan(full$exbod, full$BB, "x"),AltMan(full$exbod, full$BB, "y"), pch = 2)
points(AltMan(full$flrs, full$BB, "x"),AltMan(full$flrs, full$BB, "y"), col = "brown", pch = 3)
AltMan(full$hik, full$BB, "u")
abline(blm, col = "lightseagreen")
text(pos = 3, col = "lightseagreen", x = c(bl$means[8], bl$means[8] + .4), y  = c(bl$differences[18]+ .55,bl$differences[18] +.55),
     labels = c("R-Squared ","0.86") )
text(pos = 3, col = "lightseagreen",x = c(bl$means[8], bl$means[8] + .4), y  = c(bl$differences[18] + .49,bl$differences[18]+ .49),
     labels = c("Beta ", "-0.208") )
legend(#x = 35.5, y = -2,
  "bottomleft", bty = "n", ncol = 1, y.intersp = .5, x.intersp = .5,
  legend = c("Hikvision", "Extech", "Flir"), text.col = c("lightseagreen", "Black", "Brown"), pch =c(1,2,3))

#md/Md/m/m represents Meridian IRT; orange
bl = blandr.statistics(full$md, full$BB)
blm = lm(bl$differences ~ bl$means); summary(blm)$r.squared; blm$coefficients[2]

plot(AltMan(full$md, full$BB, "x"),AltMan(full$zk, full$BB, "y"),
     main = "Bland-Altman plot of Meridian,\nExtech on Body, and Flir vs. Subject Temp",
     col = "orange", xlab = "Means", ylab = "Differences", pch = 1)
points(AltMan(full$exbod, full$BB, "x"),AltMan(full$exbod, full$BB, "y"),pch = 2 )
points(AltMan(full$flrs, full$BB, "x"),AltMan(full$flrs, full$BB, "y"), col = "brown", pch = 3)
AltMan(full$md, full$BB, "u")
abline(blm, col = "orange")
text(pos = 3, col = "orange", x = c(bl$means[8] +.4, bl$means[8] + .8), y  = c(bl$differences[18]-.6,bl$differences[18] - .6),
     labels = c("R-Squared ","0.73") )
text(pos = 3, col = "orange",x = c(bl$means[8]+.4, bl$means[8] + .8), y  = c(bl$differences[18] - .7,bl$differences[18]- .7),
     labels = c("Beta ", "-0.469") )
legend(#x = 35.5, y = -2,
  "bottomleft", bty = "n", ncol = 1, y.intersp = .5, x.intersp = .5,
  legend = c("Meridian", "Extech", "Flir"), text.col = c("orange", "Black", "Brown"), pch = c(1,2,3))

#Combined
plot(full$BB,full$BB,ylim = c(-3.1,2), col = "black" ,type = "l",
     xlab = "Means°C", ylab = "Differences°C",
     main = "Combined Bland-Altman Plot", xlim =c(35.5, 40.56))
abline(h = -1, col = "black", lty = 2)
abline(h = 1, col = "black", lty = 2)
abline(h = 0, col = "black", lty = 1, cex = 2.1)
points(AltMan(full$flrs, full$BB, "x"),AltMan(full$flrs, full$BB, "y"), type = "p", col = "brown", pch = 2)
points(AltMan(full$bems, full$BB, "x"),AltMan(full$bems, full$BB, "y"), type = "p", col = "purple", pch = 3)
points(AltMan(full$hik, full$BB, "x"),AltMan(full$hik, full$BB, "y"), type = "p", col = "lightseagreen", pch = 4)
points(AltMan(full$dah, full$BB, "x"),AltMan(full$dah, full$BB, "y"), type = "p",col = "red", pch = 5)
points(AltMan(full$zk, full$BB, "x"),AltMan(full$zk, full$BB, "y"), type = "p", col = "darkgoldenrod", pch = 6)
points(AltMan(full$tvt, full$BB, "x"),AltMan(full$tvt, full$BB, "y"), type = "p", col = "blue", pch = 7)
points(AltMan(full$cert, full$BB, "x"),AltMan(full$cert, full$BB, "y"), type = "p", col = "deeppink", pch = 8)
points(AltMan(full$md, full$BB, "x"),AltMan(full$md, full$BB, "y"), type = "p", col = "orange", pch = 9)
text(x = c((full[21,c(12,8,6,5,4,3,2)] +rep(40,7))/2),
     y = c(c(full[21,c(12,8,6,5,4,3,2)]- c(rep(40,7)))),
     labels = c("Flir", "Meridian", "Dahua", "Hikvision", "Certify", "TVT", "Bems"),
     col = c("Brown","orange","red", "lightseagreen", "deeppink", "blue", "Purple"),
     pos = 4)
text(x = c(full[21,7]/2 + 20),
     y = c(full[21,7] - 39.82),
     labels = c("ZkTeco"),
     col = c("darkgoldenrod"),
     pos = 4)

# Variances --------------------------------------------------------------------
#analyzing basic statistics of devices

var(hik$Blackbody.Temperature) #2.40625
var(hik$FLIR.Measurement) #2.389619
var(c(hik$Blackbody.Temperature + rnorm(length(hik$Blackbody.Temperature)))) #3.312254
var(hik$Ex.Surface) #2.393869
var(hik$Ex.Body) #1.303405
var(hik$Device.Measurement) #1.585619
var(dah$Device.Measurement) #1.428571
var(zk$Device.Measurement) #0.8549048
var(cert$Device.Measurement) #0.7233333
var(md$Device.Measurement) #0.9453333
var(bems$Device.Measurement) #0.005142857
var(tvt$Device.Measurement) #0.1602857

mean(hik$Blackbody.Temperature) #37.5
mean(hik$FLIR.Measurement) #37.51905
mean(c(hik$Blackbody.Temperature + rnorm(length(hik$Blackbody.Temperature)))) #37.46232
mean(hik$Ex.Surface) #37.50238
mean(hik$Ex.Body) #38.22619
mean(hik$Device.Measurement) #37.38095
mean(dah$Device.Measurement) #37.34286
mean(zk$Device.Measurement) #37.32381
mean(cert$Device.Measurement) #37.33333
mean(md$Device.Measurement) #37.83333
mean(bems$Device.Measurement) #36.67143
mean(tvt$Device.Measurement) #36.91429

range(hik$Blackbody.Temperature) #35 40
range(hik$FLIR.Measurement) #35 40
range(c(hik$Blackbody.Temperature + rnorm(length(hik$Blackbody.Temperature)))) #34.43728 40.74725
range(hik$Ex.Surface) #35.05 40.05
range(hik$Ex.Body) #36.7 40.2
range(hik$Device.Measurement) #35.6 39.6
range(dah$Device.Measurement) #35.4 39.4
range(zk$Device.Measurement) #36.3 39.0
range(cert$Device.Measurement) #36.4 39.0
range(md$Device.Measurement) #36.9 39.8
range(bems$Device.Measurement) #36.5 36.8
range(tvt$Device.Measurement) #36.6 37.8

# Looking for similar adjustment processes --------------------------------------------------------------------

# ZK/Cert/Meridian --------------------------------------------------------------------

#I am first combining data with a dummy variable for device,
#then adjusting the devices with an offset, then seeing if
#the dummy variable is significant

#ZK and Cert
d1 =  data.frame("dev" = zk$Device.Measurement, "BB" =zk$Blackbody.Temperature, "rand" = 1)
d2 = data.frame("dev" = cert$Device.Measurement, "BB" =cert$Blackbody.Temperature, "rand" = 0)
big = rbind(d1, d2)

#adjust
d1$dev = d1$dev - lm(big$dev~  big$BB + big$rand)$coefficients[3]; lm(big$dev~  big$BB + big$rand)$coefficients[3]
#-0.00952381

#recombine
big = rbind(d1, d2)
l = lm(big$dev~  big$BB + big$rand + big$BB*big$rand); summary(l)
#p-value 0.302; big$BB:big$rand  beta 0.04883

#ZK and Meridian
d1 =  data.frame("dev" = zk$Device.Measurement, "BB" =zk$Blackbody.Temperature, "rand" = 1)
d2 = data.frame("dev" = md$Device.Measurement, "BB" = md$Blackbody.Temperature, "rand" = 0)
big = rbind(d1, d2)

#adjust
d1$dev = d1$dev - lm(big$dev~  big$BB + big$rand)$coefficients[3];lm(big$dev~  big$BB + big$rand)$coefficients[3]
#-0.5095238

#recombine
big = rbind(d1, d2)
l = lm(big$dev~  big$BB + big$rand + big$BB*big$rand); summary(l)
#p-value 0.702; big$BB:big$rand  beta -0.02078

#Cert and Meridian
d1 =  data.frame("dev" = cert$Device.Measurement, "BB" =cert$Blackbody.Temperature, "rand" = 1)
d2 = data.frame("dev" = md$Device.Measurement, "BB" = md$Blackbody.Temperature, "rand" = 0)
big = rbind(d1, d2)

#adjust
d1$dev = d1$dev - lm(big$dev~  big$BB + big$rand)$coefficients[3]; lm(big$dev~  big$BB + big$rand)$coefficients[3]
#-0.5

#recombine
big = rbind(d1, d2)
l = lm(big$dev~  big$BB + big$rand + big$BB*big$rand); summary(l)
#p-value 0.202; big$BB:big$rand  beta -0.06961

#plot
d3= data.frame("dev" = zk$Device.Measurement, "BB" = zk$Blackbody.Temperature, "rand" = 1)
big = rbind(d3, d2)
#adjust
d3$dev = d3$dev - lm(big$dev~  big$BB + big$rand)$coefficients[3]; lm(big$dev~  big$BB + big$rand)$coefficients[3]
#-0.5095238

plot(d1$BB, d1$dev, col = 1, ylab = "Adjusted Device Reading",
     xlab = "Black Body Temperature °C", main = "ZKTeco, Certify, and Meridian With Offsets")
points(d1$BB, d1$dev, col = 1, type = "l")
points(d2$BB, d2$dev, col = 2)
points(d3$BB, d3$dev, col = 3)
points(d2$BB, d2$dev, col = 2, type = "l")
points(d3$BB, d3$dev, col = 3, type = "l")
legend("topleft",bty = "n", legend = "At the 10% level\nwe fail to reject\nthe null hypothesis that\nthese devices are different")

# Hik and Dah --------------------------------------------------------------------
#Hikvision and Dahua
d1 =  data.frame("dev" = hik$Device.Measurement, "BB" =hik$Blackbody.Temperature, "rand" = 1)
d2 = data.frame("dev" = dah$Device.Measurement, "BB" =dah$Blackbody.Temperature, "rand" = 0)
big = rbind(d1, d2)

#adjust
d1$dev = d1$dev - lm(big$dev~  big$BB + big$rand)$coefficients[3]; lm(big$dev~  big$BB + big$rand)$coefficients[3]
#0.03809524

#unadj
l = lm(big$dev~  big$BB + big$rand + big$BB*big$rand); summary(l)
#p-value 0.0489 *; big$BB:big$rand  beta 0.04000

#recombine
big = rbind(d1, d2)
l = lm(big$dev~  big$BB + big$rand + big$BB*big$rand); summary(l)
#p-value 0.0489 *; big$BB:big$rand  beta 0.04000

plot(d1$BB, d1$dev, col = 1, ylab = "Adjusted Device Reading",
     xlab = "Black Body Temperature °C", main = "Hikvision and Dahua With Offsets")
points(d1$BB, d1$dev, col = 1, type = "l")
points(d2$BB, d2$dev, col = 2)
points(d2$BB, d2$dev, col = 2, type = "l")
legend("topleft",bty = "n", legend = "P-Value of .0489\nCorrelation Coefficient beta of .04")

# TVT and Bems --------------------------------------------------------------------

d1 =  data.frame("dev" = tvt$Device.Measurement, "BB" =tvt$Blackbody.Temperature, "rand" = 1)
d2 = data.frame("dev" = bems$Device.Measurement, "BB" =bems$Blackbody.Temperature, "rand" = 0)
big = rbind(d1, d2)

#adjust
d1$dev = d1$dev - lm(big$dev~  big$BB + big$rand)$coefficients[3]; lm(big$dev~  big$BB + big$rand)$coefficients[3]
#0.2428571

#recombine
big = rbind(d1, d2)
l = lm(big$dev~  big$BB + big$rand + big$BB*big$rand); summary(l)
#p-value 1.39e-07 ***; big$BB:big$rand  beta 0.215065

plot(d1$BB, d1$dev, col = 1, ylab = "Adjusted Device Reading",
     xlab = "Black Body Temperature °C", main = "Hikvision and Dahua With Offsets")
points(d1$BB, d1$dev, col = 1, type = "l")
points(d2$BB, d2$dev, col = 2)
points(d2$BB, d2$dev, col = 2, type = "l")

# Extech Bullets Different --------------------------------------------------------------------

d1 =  data.frame("dev" = hik$Device.Measurement, "BB" =hik$Blackbody.Temperature, "rand" = 1)
d2 = data.frame("dev" = hik$Ex.Body, "BB" =hik$Blackbody.Temperature, "rand" = 0)
big = rbind(d1, d2)

#adjust
d1$dev = d1$dev - lm(big$dev~  big$BB + big$rand)$coefficients[3]; lm(big$dev~  big$BB + big$rand)$coefficients[3]
#-0.8452381

#recombine
big = rbind(d1, d2)
l = lm(big$dev~  big$BB + big$rand + big$BB*big$rand); summary(l)
#p-value 0.00216 **; big$BB:big$rand  beta 0.02328

d1 =  data.frame("dev" = dah$Device.Measurement, "BB" =dah$Blackbody.Temperature, "rand" = 1)
d2 = data.frame("dev" = dah$Ex.Body, "BB" =dah$Blackbody.Temperature, "rand" = 0)
big = rbind(d1, d2)

#adjust
d1$dev = d1$dev - lm(big$dev~  big$BB + big$rand)$coefficients[3]; lm(big$dev~  big$BB + big$rand)$coefficients[3]
#-1.028571

#recombine
big = rbind(d1, d2)
big = big[big$BB<36.5,]
l = lm(big$dev~  big$BB + big$rand + big$BB*big$rand); summary(l)
#p-value 0.00216 **; big$BB:big$rand  beta 0.02328

plot(d1$BB, d1$dev, col = 1, ylab = "Adjusted Device Reading",
     xlab = "Black Body Temperature °C", main = "Hikvision and Dahua With Offsets")
points(d1$BB, d1$dev, col = 1, type = "l")
points(d2$BB, d2$dev, col = 2)
points(d2$BB, d2$dev, col = 2, type = "l")


#!/usr/bin/Rscript

# Bhishan Poudel
# Jan 8, 2016

# 5 data types in R : vectors, matrix, list, data frame and a factor

# Creating a Vector
# cat("\nCreating a Vector")
# cat("\nVectors are generally created using the c() function. \n")
# cat("\nVectors contain element of the same type. \nDifferent data types ")
# cat("available in R are logical, integer, double, character, complex and raw.\n")
# cat("Since, a vector must have elements of the same type\n")
# cat("this function will try and coerce elements to the same type, \nif they are different.")
# cat("Coercion is from lower to higher types from logical to integer to double to character.\n")

# numeric vectors
x <- c(1, 5, 4, 9, 0)
typeof(x)
# [1] "double"
length(x)
# [1] 5
x[order(x)]
# character vectors
y <- setNames(x, letters[1:4])
y[c("d", "c", "a")]

# example 2
x <- c(1, 5.4, TRUE, "hello")
x
# [1] "1"     "5.4"   "TRUE"  "hello"
typeof(x)
# [1] "character"

cat("\nCreating vectors using seq(arguments, by=.., length.out=..,etc) \n")
cat("help(seq) \n")

cat("seq(from = 1, to = 1, by = ((to - from)/(length.out - 1)),")
cat("length.out = NULL, along.with = NULL, ...) \n")
cat("seq() examples\n")

seq(10)
seq_len(10)
seq(0:10)
seq(5:1)
seq(-5)
seq(1:-5)  # from 1 to 7
seq(0,10,2)
seq(0, 1, length.out = 11)
# [1] 0.0 0.1 0.2 0.3 0.4 0.5 0.6 0.7 0.8 0.9 1.0
seq(stats::rnorm(20)) # effectively 'along'
# [1]  1  2  3  4  5  6  7  8  9 10 11 12 13 14 15 16 17 18 19 20
seq(1, 9, by = 2)     # matches 'end'

seq(1, 9, by = pi)    # stays below 'end'

seq(1, 6, by = 3)

cat("\nAccessing Elements in Vector")
cat("\nVector index in R starts from 1, unlike most programming languages")
cat("where index start from 0. \n")
# help(":")
x <- 1:7; x
x[c(2, 4,2)]     # access 2nd and 4th element
#x[c(2, -4)]     # cannot mix positive and negative integers
x[c(2.4, 3.54)]  # real numbers are truncated to integers
# [1] 2 3
x[-c(3, 1)]

cat("\nUsing logical vector \n")
# consider the following vector s of length 5.
s = c("aa", "bb", "cc", "dd", "ee")

# To retrieve the the second and fourth members of s,
# we define a logical vector L of the same length,
# and have its second and fourth members set as TRUE.

L = c(FALSE, TRUE, FALSE, TRUE, FALSE)
s[L]
# [1] "bb" "dd"

# The code can be abbreviated into a single line.
s[c(FALSE, TRUE, FALSE, TRUE, FALSE)]
# [1]      "bb"         "dd"

x <- 1:7; x
#                                                                 1 2 3 4 5 6 7
x[c(TRUE, FALSE)] # [1] 1 3 5 7                                   T F T F T F T
x[c(TRUE, FALSE, FALSE)] # [1] 1 4 7                              T F F T F F T
x[c(TRUE, FALSE, FALSE, TRUE)]# [1] 1 4 5                         T F F T T F F
x[c(TRUE, FALSE, FALSE, TRUE,FALSE)] # [1] 1 4 6                  T F F F F T F
x[c(TRUE, FALSE, FALSE, TRUE,FALSE,TRUE)]  # [1] 1 4 6 7          T F F T F T T
x[c(TRUE, FALSE, FALSE, TRUE,FALSE,TRUE,F)]  # [1] 1 4 6          T F F T F T F
#   1     2      3      4    5     6     7

x[c(TRUE, TRUE, NA, FALSE)]

cat("\nfiltering vectors based on conditions \n")
x[x<4]  # filtering vectors based on conditions
#[1] -3 -1

x[x>=4]
#[1] 3

cat("\nUsing character vector as index \n")
x <- c("first"=3, "second"=0, "third"=9)
names(x)
# [1] "first"  "second" "third"

x["second"]
#second
#    0

x[c("first", "third")]
#first third
#   3     9

cat("\nModifying a Vector \n")
x <- -3:2 ;x
#[1] -3 -2 -1  0  1  2

x[2] <- 0; x        # modify 2nd element
#[1] -3  0 -1  0  1  2

x[x<0] <- 5; x   # modify elements less than 0
#[1] 5 0 5 0 1 2

x <- x[1:4]; x      # truncate x to first 4 elements
#[1] 5 0 5 0
cat("\nDeleting a Vector")
cat("\nWe can delete a vector by simply assigning a NULL to it.  \n")
x <- -3:2 ;x
# [1] -3 -2 -1  0  1  2
x <- NULL

x
#NULL
x[4]
#NULL


sigmoid <- function(x) {
    if (x < 0.0) {
        z <- exp(x)
        return(z / (1.0 + z))
    }
    return(1.0 / (1.0 + exp(-x)))
}


library(deSolve)
library(ggplot2)
library(reshape2)

sis_ode <- function(times,x,parms){
  with(as.list(c(parms,x)),{
    # ODEs
    SH<-nH-x[[1]] #Calculate SH as nH-IH
    SL<-(1-nH)-x[[2]] #Calculate SL as nL-IL
    dIH <-+(betaHH*IH+betaHL*IL)*SH-gamma*IH
    dIL <-+(betaLH*IH+betaLL*IL)*SL-gamma*IL

    der<-c(dIH,dIL)
    list(der)
  })
}

parms <- c(betaHH=10,betaHL=0.1,betaLH=0.1,betaLL=1,gamma=1,nH=0.2)
x <- c(IH=0.00001,IL=0.001)
times <-seq(0,15,1)
sis_out <- as.data.frame(lsoda(x,times,sis_ode,parms))

sis_out_long <- melt(sis_out,"time") #Collapse dataset from "wide" to "long" format for plotting
ggplot(sis_out_long,aes(x=time,y=value,colour=variable,group=variable)) + geom_line(lwd=2) +
  labs(x="Time (Years)",y="Proportion of Population",color="Risk Group")


REBOL [
    title: "Linear algebra package"
    doc: {
	A simple implementation of a linear algebra package doing the most simple things.

	Remember that matrixes are stored as a list of rows and vectors as a list
	}
]

ff-matrix: func [ A ][ new-line/all A on ]

swap-rows: func [ M i1 i2] [ swap at M i1 at M i2 ]
vector-mult: func [ x1 x2 /local s ] [
    s: 0.0
    ;foreach x x1 [ s: s + (  x * first+ x2 ) ]
    repeat i length? x1 [ s: s + ( ( pick x1 i ) * pick x2 i ) ]
    s
]
;vector-sum: func [ v /local sum ] [ sum: 0 forall v [ sum: sum + first v ] sum ]
vector-sum: func [ v /local sum ] [ sum: 0. repeat i length? v [ sum: sum + pick v i ] sum ]

;mult-vector-scalar: func [ v s ][ map-each t v [ t * s ]]
mult-vector-scalar: func [ v s ][ v: copy v repeat i length? v [ poke v i s * pick v i ] v ]

negate-vector: func [ v ][ v: copy v forall v [ v/1: negate v/1 ] v ]
negate-matrix: func [ A ][ A: copy A forall A [ A/1: negate-vector A/1 ] A ]

;add-vector-scalar: func [ v s /local res][  map-each x v [ s + x ] ]
add-vector-scalar: func [ v s ][ v: copy v repeat i length? v [ poke v i s + pick v i ] v ]

;add-vector-vector: func [ v w ][ map-each t v [ t + first+ w ]]
add-vector-vector: func [ v w ][ v: copy v repeat i length? v [ poke v i (pick w i) + pick v i ] v ]

;add-mult-vector-vector: func [ v a1 w a2 ][ map-each t v [ t *  a1 + ( a2 * first+ w )]]
add-mult-vector-vector: func [ v a1 w a2 ][ v: copy v repeat i length? v [ poke v i (a1 * pick v i ) + ( a2 * pick w i ) ] v ]

add-matrix-matrix: func [ A B /local result ][
    result: copy []
    foreach x A [
	append/only result add-vector-vector x first+ B
    ]
]

sub-matrix-matrix: func [ A B /local result ][
    add-matrix-matrix A negate-matrix B
]

sub-matrix-matrix: func [ A B ][
    add-matrix-matrix A negate-matrix B
]

mult-matrix-vector-ol: func [ M x /local n ret ] [
    n: length? M
    ret: make block! n
    foreach y M [
	append ret vector-mult y x
    ]
]
mult-matrix-vector: func [ M x /local n ret ] [
    M: copy M
    repeat i length? M [ poke M i vector-mult pick M i x ]
    M
]
mult-matrix-matrix: func [
    A B
    /A-transposed {Use if first matrix is a transposed version of what it should be}
    /B-transposed {Use if first matrix is a transposed version of what it should be}
    /symmetric {Use if you know the result is symetric, to be implemented}
    /local
	C
][
    n: length? A
    unless B-transposed  [B: transpose-matrix B]
    if A-transposed  [A: transpose-matrix A]
    C: make  block! n
    foreach x B [ append/only C mult-matrix-vector A x ]
    C: transpose-matrix C
]

mult-matrix-scalar: func [ A k /local result ][
    result: copy []
    foreach x A  [
	append/only result mult-vector-scalar x k
    ]
    result
]

rand-vector: func [ n /local v ] [ v: make block! n  loop n [ append v ( random 1000. )  - 500. ] v ]

rand-matrix: func [ n /local A ] [
    A: make block! n
    loop n [ append/only A rand-vector n ]
    A
]

mult-add-vectors: func [
    r1 [ block! ] {Row}
    k1  [number!] {multiplicator}
    r2 [ block! ] {Row}
    k2  [number!] {multiplicator}
    /local
    r n
] [
    r: make block! n: length? r1
    repeat i n [
	append r r1/:i * k1 + ( r2/:i * k2 )
    ]
    r
]
mult-row: func [ r k ] [ map-each x copy r [ x * k ] ]

form-matrix: func [ 'M
    /local
    r ret
] [
    ret: reform [  M ":" ]
    foreach r get M [ repend ret reform [ tab form r newline ] ]
]

get-col: func [
    M { The matrix}
    c {The column index}
    /local
	ret
	n
    ] [
    n: length? M
    ret: make block! n
    foreach x M [ append ret x/:c ]
    ret
]

get-cols: func [
    M { The matrix}
    from {The first column}
    to {The last column}
    /local
	ret
	n
    ] [
    n: length? M
    ret: make block! n
    foreach x M [ append/only ret copy/part at x from to - from + 1 ]
    ret
]

transpose-matrix: func [A /local ret m ] [
    ret: make block! n: length? A/1
    m: length? A

    repeat i n [
	append/only ret new-line/all get-col A i off
    ]
    new-line/all ret on
]

inverse-matrix: func [ A /local Ainv ][
    linear-eq-solve A eye length? A
]
determinant-definition: func [
    {Calculates the determinant using the definitioin of such, very time
    consuming and memory hungry}
    A
    /local
	sum B mult n val

] [
    if 1 = n: length? A [ return first first A ]
    mult: 1
    sum: 0
    repeat i n [
	B: copy/deep A
	f: B/:i/1
	remove at B i
	forall B [ remove first B ]
	sum: sum + ( mult * f * determinant B )
	mult: negate mult
    ]
    sum
]

determinant: func [
    A
    /local
][
    A: forward-decomposition/mult A
    d: diag first A
    m: second A forall d [ m: m * first d ]
    m
]

eye: func [ n /local B Bi ] [
    Bi: make block! n
    B: make block! n
    loop  n [ append Bi 0. ]
    loop  n [ append/only B copy Bi ]
    repeat i n [ B/:i/:i: 1. ]
    B
]

diag: func [ A
    /local
	ret
] [
    n: length? A
    ret: make block! n
    either block? A/1 [
	repeat i n [ append ret A/:i/:i ]
    ][
	zeros: make block! n loop n [ append zeros 0. ]
	loop n [ append/only ret copy zeros ]
	repeat i n [ ret/:i/:i: A/:i ]
    ]
    ret
]

forward-decomposition: func [
    {Does forward decomposition, adds an eye matrix in case A is nxn}

    A [ block! ]
    /mult

    /local x n row B m
][
    A: copy/deep A
    n: length? A
    m: 1

    if n = length? first A [
	B: eye n
	foreach row A [ append row first+ B ]
    ]

    x: make block! n
    ; Forward substitutioin
    repeat i n [
	; Find the row with largest pivot element and move the row to the first row
	for j i + 1 n 1 [
	    if ( abs A/:j/:i ) > abs A/:i/:i [ m: negate m swap-rows A i j ]
	]
	; Now we should have the row with the best diagonal on row i
	;
	d-element: negate A/:i/:i

	for j i + 1 n 1 [
	    A/:j:   mult-add-vectors	A/:j	    1
					A/:i	    A/:j/:i / d-element
	    A/:j/:i: 0. ; In case there are numerical rests
	]
    ]
    either mult [ reduce [ A m ] ] [ A ]
]

linear-eq-solve: func [
    {Solves the linear equation y = A x
     y = [ y/1 y/2 ... y/n ]
     A = [ [ A11 A12 ... A1n ] [ A21 A22 ... A2n ] ... [1An An2 ... Ann] ]
     x = [ x/1 x/2 ... x/n ]
    }

    A [ block! ] { Block of size n x n }
    y [ block! ] { Block of size n }

    /local x n row
][
    A: copy/deep A
    foreach row A [ append row first+ y ]
    A: forward-decomposition A
    n: length? A
    ; Backward substitution
    ; print {Backward substitution}
    for i n 1 -1 [
	;Normalize row i
	; print [ "pre normalize row" i  "multiplied with" 1 / A/:i/:i ] print form-matrix A
	row: A/:i: mult-row A/:i    1 / A/:i/:i
	; print [ "Normalized row" i ] print form-matrix A

	repeat j i - 1 [
	    A/:j: mult-add-vectors A/:j 1 row negate A/:j/:i
	    ; print [ "Reduced row" j ] print form-matrix A
	]
    ]
    either block? y/1 [
	get-col A n + 1
    ][
	get-cols A n + 1  length? A/1
    ]
]

; Tests
; Linear algebra
if all [value? 'debug-linalg debug-linalg ] [
    A: [    [ 1 2 ]
	    [ 2 3 ]
       ]
    x-solved: [ 2 3 ]
    y: mult-matrix-vector A x-solved

    print form-matrix A
    print form-matrix y

    x: linear-eq-solve  A y
    print form-matrix x
    print either x = x-solved [ {Solved correctly} ] [ {Not a correct solution} ]

    A: rand-matrix 8
    x-solve: rand-vector 8
    y: mult-matrix-vector A x-solve
    x: linear-eq-solve A y
    print form-matrix x-solve
    print form-matrix x
    print either x = x-solved [ {Solved correctly} ] [ {Not a correct solution} ]

    print [ {\n\t\Determinant\n
	}]
    A: [ [ 1 1 ] [ 2 2] ]
    print [ "Determinant of \n" form-matrix A ]
    det: determinant A
    print [ "is" det ]
    either det = 0 [ print "OK" ] [ print "Error!" ]

    A: [ [ 1 1 5 ] [ 2 2 7 ]  [ 14 14 49 ] ]
    print [ "Determinant of " form-matrix A ]
    det: determinant A
    print [ "is" det ]
    either det = 0 [ print "OK" ] [ print "Error!" ]

    A: transpose-matrix [ [ 1 1 5 ] [ 2 2 7 ]  [ 14 14 49 ] ]
    print [ "Determinant of " form-matrix A ]
    det: determinant A
    print [ "is" det ]
    either det = 0 [ print "OK" ] [ print "Error!" ]

    A: [ [ 1 1 5 ] [ 20 2 7 ]  [ 14 14 49 ] ]
    print [ "Determinant of " form-matrix A ]
    det: determinant A
    print [ "is" det ]
    either det != 0 [ print "OK" ] [ print "Error!" ]
]
; vim: ai sw=4 sts=4


library(dplyr)
library(igraph)
options(scipen=999)

print(test)

all_flights_2018 <- all_flights_2018 %>% filter(flights>0)
all_flights_1998 <- all_flights_1998 %>% filter(flights>0)

get_null_df_and_metrics <-function(df) {
  # select origin, dest, flights, make flights = to weight
  air_df = df %>% select(ORIGIN, DEST) %>% rename(from = ORIGIN, to = DEST)

  # select unweighted or weighted
  #weighted_df <- (df %>% select(ORIGIN, DEST, flights) %>%
  #                                    rename(from = ORIGIN, to = DEST, weight = flights))
  #weighted_g <- graph.data.frame(weighted_df, directed = TRUE)
  #g <- weighted_g

  unweighted_g <- graph_from_edgelist(df %>% select(ORIGIN, DEST) %>% as.matrix())
  g <- unweighted_g
  print(is_weighted(g))

  # get metrics of observed network
  observed_deg <- (degree(g, mode = "all"))
  observed_betweenness <- (betweenness(g))
  observed_mean_dist <- mean_distance(g)
  observed_diameter <- diameter(g)

  # get random network params
  numb_edges <- length(E(g))
  numb_vertices <-length(V(g))
  numb_flights <- sum(df$flights) # attempt to make rand grapgh with edges == total weight
  p_edges <- (numb_edges/(numb_vertices*(numb_vertices-1)))

  # make random network
  rand_g <- sample_gnp(n=numb_vertices, p=p_edges, directed=TRUE) %>%
    set_vertex_attr("label", value = V(g))
  V(rand_g)$name <- V(g)$name # name random network vertices same as original graphs

  # get metrics from random network
  rand_betweenness = (betweenness(rand_g))
  rand_deg <- (degree(rand_g, mode='all'))
  rand_mean_dist <- mean_distance(rand_g)
  rand_diameter <- diameter(rand_g)

  # make random g into a df
  rand_df <- as_data_frame(rand_g)
  names(rand_df) <- c('ORIGIN', 'DEST') # used for joining back to original coordinates
  # get the lat and longs
  original_origins <- select(df, c(ORIGIN, origin_lat, origin_lon))
  original_dests <- select(df, c(DEST, dest_lat, dest_lon))
  # combine random network nodes with lat/lons, dedupe
  rand_df_coords <- merge(rand_df, original_origins, by='ORIGIN', all.x=T)
  rand_df_coords <- merge(rand_df_coords, original_dests, by='DEST', all.x=T)
  rand_df_coords_deduped <-  rand_df_coords[!duplicated(rand_df_coords), ]

  # make a new df with all the stats for later use
  metrics_df <- data.frame(observed_betweenness, observed_deg, observed_mean_dist, observed_diameter,
                           rand_betweenness, rand_deg, rand_mean_dist, rand_diameter,
                           numb_vertices, numb_edges, numb_flights)
  print(colMeans(metrics_df))
  return(list('rand_df' =rand_df_coords_deduped, 'metrics_df' = metrics_df))
}

#Unweighted metrics for presentation
results <- get_null_df_and_metrics(all_flights_1998)
all_1998_rand_Df <- results$rand_df
all_1998_metrics <- results$metrics_df
all_1998_summary <- data.frame(colMeans(all_1998_metrics))

results <- get_null_df_and_metrics(all_flights_2018)
all_2018_rand_Df <- results$rand_df
all_2018_metrics <- results$metrics_df
all_2018_summary <- data.frame(colMeans(all_2018_metrics))

plot_network_unweighted(df_map=all_1998_rand_Df , map_title="Null Model, 1998", point_color='green')
plot_network_unweighted(df_map=all_flights_1998, map_title='Unweighted Network, 1998', point_color='red')

plot_network_unweighted(df_map=all_2018_rand_Df , map_title="Null Model, 2018", point_color='green')
plot_network_unweighted(df_map=all_flights_2018, map_title='Unweighted Network, 2018', point_color='red', alpha = .01,)

hist(all_2018_metrics$observed_deg, main="Degree Distribution of 2018 Network", col='red',
     xlab="Node Degree")
hist(all_2018_metrics$rand_deg, main="Degree Distribuion of 2018 Null Model", col='green',
     xlab="Node Degree")
hist(all_1998_metrics$observed_deg, main="Degree Distribution of 1998 Network", col='red',
     xlab="Node Degree")
hist(all_1998_metrics$rand_deg, main="Degree Distribuion of 1998 Null Model", col='green',
     xlab="Node Degree")

#write.csv(all_2018_metrics, 'all_2018_metrics.csv')
sum(all_flights_1998$flights)
summary(all_flights_1998)

# Make graphics for delta
results <- get_null_df_and_metrics(DL_2018)
dl_2018_rand_df <- results$rand_df
dl_2018_metrics <- results$metrics_df

#weighted diameter
weighted_df <- (all_flights_1998 %>% select(ORIGIN, DEST, flights) %>%
                  rename(from = ORIGIN, to = DEST, weight = flights))
g <- graph.data.frame(weighted_df, directed = TRUE)
distance_weighted <- distances(g)

farthest_vertices(g)
get.diameter(g)
diameter(g)

unweighted_df <- (all_flights_1998 %>% select(ORIGIN, DEST) %>%
                  rename(from = ORIGIN, to = DEST))
g <- graph.data.frame(unweighted_df, directed = TRUE)
farthest_vertices(g)
get.diameter(g)
diameter(g)

get_weighted_metrics <-function(df) {
  # select origin, dest, flights, make flights = to weight
  air_df = df %>% select(ORIGIN, DEST) %>% rename(from = ORIGIN, to = DEST)

  weighted_df <- (df %>% select(ORIGIN, DEST, flights) %>%
                    rename(from = ORIGIN, to = DEST, weight = flights))
  weighted_g <- graph.data.frame(weighted_df, directed = TRUE)
  g <- weighted_g
  print(is_weighted(g))

  # get metrics of observed network
  observed_strength <- (strength(g))
  observed_betweenness <- (betweenness(g))
  observed_mean_dist <- mean_distance(g)
  observed_diameter <- diameter(g)

  # get random network params
  numb_edges <- length(E(g))
  numb_vertices <-length(V(g))
  numb_flights <- sum(df$flights) # attempt to make rand grapgh with edges == total weight

  # make a new df with all the stats for later use
  metrics_df <- data.frame(observed_betweenness, observed_strength, observed_mean_dist, observed_diameter,
                           numb_vertices, numb_edges, numb_flights)
  print(colMeans(metrics_df))
  return(metrics_df)
}

all_1998_weighted_metrics <- get_weighted_metrics(all_flights_1998)
all_1998_weighted_summary <- data.frame(colMeans(all_1998_weighted_metrics))

all_2018_weighted_metrics <- get_weighted_metrics(all_flights_2018)
all_2018_weighted_summary <- data.frame(colMeans(all_2018_weighted_metrics))

hist(dl_2018_metrics$observed_betweenness, main="Observed Network, Delta 2018", col='blue',
     xlab="Betweenness of Each Node")
hist(dl_2018_metrics$rand_betweenness, main="Null Model, Delta 2018 ", col='blue',
     xlab="Betweenness of Each Node")
hist(dl_2018_metrics$observed_deg, main="Observed Network, Delta 2018", col='blue',
     xlab="Node Degree")
hist(dl_2018_metrics$rand_deg, main="Null Model, Delta 2018 ", col='blue',
     xlab="Node Degree")

plot(log(dl_2018_metrics$observed_deg), log='y')
plot(log(dl_2018_metrics$rand_deg), log='y')

p <- ggplot(dl_2018_metrics, aes(x = (range), y=log(observed_deg))) +
  geom_point() +
  scale_y_log10()
p

plot(log(wn_2018_metrics$observed_deg), log='y')
plot(log(wn_2018_metrics$rand_deg), log='y')

# Experimentation with random weights for the weighted graph
#dl_2018_rand_df$flights <- sample(1:5,nrow(dl_2018_rand_df),replace=TRUE)
#DL_2018$flights <- sample(1:5,nrow(DL_2018),replace=TRUE)
# use plot network function from "Data_Pipeline_with_maps"
plot_network_unweighted(df_map=dl_2018_rand_df, map_title="Null Model, Delta 2018", point_color='blue')
plot_network_unweighted(df_map=DL_2018, map_title='Delta in 2018, Unweighted', point_color='blue')

# Southwest
results <- get_null_df_and_metrics(WN_2018)
wn_2018_rand_df <- results$rand_df
wn_2018_metrics <- results$metrics_df

hist(wn_2018_metrics$observed_betweenness, main="Observed Network, Southwest 2018", col='gold',
     xlab="Betweenness")
hist(wn_2018_metrics$rand_betweenness, main="Null Model, Southwest 2018 ", col='gold',
     xlab="Betweenness")
hist(wn_2018_metrics$observed_deg, main="Observed Network, Southwest 2018", col='gold',
     xlab="Degree")
hist(wn_2018_metrics$rand_deg, main="Null Model, Southwest 2018 ", col='gold',
     xlab="Degree")

# Experimentation with random weights for the weighted graph
#wn_2018_rand_df$flights <- sample(1:5,nrow(wn_2018_rand_df),replace=TRUE)
#WN_2018$flights <- sample(1:5,nrow(WN_2018),replace=TRUE)
# use plot network function from "Data_Pipeline_with_maps"


#R for repeated measures
library(car)
data <- read.table(("http://www.uvm.edu/~dhowell/methods8/DataFiles/KingLong.dat"), header = TRUE)
   # Data are already in long form.
####################################################################
# > head(data)                                                     #
#  group subj interval  dv                                         #
#   1     1    1        1 150                                      #
#   2     1    1        2  44                                      #
#   3     1    1        3  71                                      #
#   4     1    1        4  59                                      #
#   5     1    1        5 132                                      #
#   6     1    1        6  74                                      #
####################################################################
attach(data)
kingaov <- aov(outcome~factor(Group)* factor(Interval)+Error(factor(subject)))
print(summary(kingaov))

###########################################################################
#   Error: factor(subj)                                                   #
#                 Df Sum Sq Mean Sq F value Pr(>F)                        #
#   factor(group)  2 285815  142908     7.8 0.0029 **                     #
#   Residuals     21 384722   18320                                       #
#   ---                                                                   #
#   Signif. codes:  0 ‘***’ 0.001 ‘**’ 0.01 ‘*’ 0.05 ‘.’ 0.1 ‘ ’ 1        #
#                                                                         #
#   Error: Within                                                         #
#                                   Df Sum Sq Mean Sq F value Pr(>F)      #
#   factor(interval)                 5 399737   79947   29.85 <2e-16 ***  #
#   factor(group):factor(interval)  10  80820    8082    3.02 0.0022 **   #
#   Residuals                      105 281199    2678                     #
#   ---                                                                   #
#   Signif. codes:  0 ‘***’ 0.001 ‘**’ 0.01 ‘*’ 0.05 ‘.’ 0.1 ‘ ’ 1        #
###########################################################################

interaction.plot(Interval, factor(Group), outcome, type="b", pch = c(2,4,6),
  legend = "F", col = c(3,4,6))
legend(4, 300, c("same", "different", "control"), col = c(4,6,3),
                      text.col = "green4", lty = c(2, 1, 3), pch = c(4, 6, 2),
                      merge = TRUE, bg = 'gray90')

detach(datLong)

RFrontEndSolution/Tests Repo/Rscripts All (163 files)/KingAnova2.r


#' GLS prediction intervals
#'
#' Computes prediction intervals for a GLS regression. When the variance covariance matrix is based on a phylogeny, this computes the prediction intervals for a phylogenetic regression (PGLS).
#' @param Y Dependent variable.
#' @param X Independent variable.
#' @param Sigma Matrix describing the covariance among data points. For the phylogenetic regression, this is based on a phylogeny (vcv(tree)).
#' @param k The sample size of the estimated future points.
#' @return GLS results.
#' @return Prediction intervals of the estimates ('PI').
#' @return Prediction intervals of unobserved values of Y ('PI.plot').
#' @references Smaers & Rohlf (2016) Testing species' deviations from allometric preductions using the phylogenetic regression. Evolution. 70 (5): 1145-1149.
#' @examples see https://smaerslab.com/software/
#' @export

gls.pi<-function(Y,X,Sigma,k){
      n<-length(X)
#Standardize sigma to reduce rounding errors
      tr<-sum(diag(Sigma))
      Sigma<-n*Sigma/tr
#Input
      invSigma<-solve(Sigma)
#pgls mean and variance
      X1<-rep(1,n)
      q<-2          # correct if multivariate!!
      C1<-solve(t(X1)%*%invSigma%*%X1)
      Y_PGLSmean<-c(C1%*%t(X1)%*%invSigma%*%Y)
      Y_PGLSdeviations = Y - Y_PGLSmean
      Y_PGLSvariance = (t(Y_PGLSdeviations)%*%invSigma%*%Y_PGLSdeviations)/(n-1)
      SE_Y_mean = sqrt(Y_PGLSvariance/n)
#Regression
      XX<-cbind(rep(1,n),X)
      C<-solve(t(XX)%*%invSigma%*%XX)
      w<-C%*%t(XX)%*%invSigma
      B<-w%*%Y
      Yhat<-XX%*%B
      Yresid=Y-Yhat
      Y_MSEresid<-c((t(Yresid)%*%invSigma%*%Yresid)/(n-q))
      a<-B[1]
      b<-B[2]
#SE of statistics
      SEa<-sqrt(diag(C)*Y_MSEresid)[1]
      SEb<-sqrt(diag(C)*Y_MSEresid)[2]
#Save model
      intercept<-cbind(a,SEa)
      slope<-cbind(b,SEb)
      model<-rbind(intercept,slope)
      colnames(model)<-c("Estimate","Std.Error")
      rownames(model)<-c("intercept","slope")
#predint
      SEYhat<-sqrt((diag(XX%*%C%*%t(XX))+c(1/k))%*%((t(Yresid)%*%invSigma%*%Yresid)/(n-q)))
      PI<-cbind(X,Yhat,SEYhat)
            Lower2.5<-Yhat-qt(0.975,n)*SEYhat
            Lower5<-Yhat-qt(0.95,n)*SEYhat
            Upper5<-Yhat+qt(0.95,n)*SEYhat
            Upper2.5<-Yhat+qt(0.975,n)*SEYhat
      PI<-cbind(PI,Lower2.5)
      PI<-cbind(PI,Lower5)
      PI<-cbind(PI,Upper5)
      PI<-cbind(PI,Upper2.5)
      PI<-PI[order(PI[,1]),]
      colnames(PI)<-c("X","Yhat","SEYhat","Lower2.5","Lower5","Upper5","Upper2.5")
      PI<-as.data.frame(PI)
#confint extrapolated
      Xi<-seq(c(min(X)-abs(max(X))),to=c(abs(max(X))*5),length.out=100)
      Z<-c(Xi)
      ZZ<-cbind(rep(1,length(Z)),Z)
      SEYhat.Xi<-sqrt((diag(ZZ%*%C%*%t(ZZ))+c(1/k))%*%((t(Yresid)%*%invSigma%*%Yresid)/(n-q)))
      Yhat.Xi<-a+b*Xi
            Lower2.5.Yhat.Xi<-Yhat.Xi-qt(0.975,n)*SEYhat.Xi
            Lower5.Yhat.Xi<-Yhat.Xi-qt(0.95,n)*SEYhat.Xi
            Upper5.Yhat.Xi<-Yhat.Xi+qt(0.95,n)*SEYhat.Xi
            Upper2.5.Yhat.Xi<-Yhat.Xi+qt(0.975,n)*SEYhat.Xi
      PI.plot<-cbind(Xi,Yhat.Xi,SEYhat.Xi,Lower2.5.Yhat.Xi,Lower5.Yhat.Xi,Upper5.Yhat.Xi,Upper2.5.Yhat.Xi)
      colnames(PI.plot)<-c("X","Yhat","SEYhat","Lower2.5","Lower5","Upper5","Upper2.5")
      PI.plot<-as.data.frame(PI.plot)
results<-list(model,PI,PI.plot)
names(results)<-c("model","PI","PI.plot")
return(results)
}


# Define consts
weights <- c(panacea=0.3, ichor=0.2, gold=2.0)
volumes <- c(panacea=0.025, ichor=0.015, gold=0.002)
values <- c(panacea=3000, ichor=1800, gold=2500)
sack.weight <- 25
sack.volume <- 0.25
max.items <- floor(pmin(sack.weight/weights, sack.volume/volumes))

# Some utility functions
getTotalValue <- function(n) sum(n*values)
getTotalWeight <- function(n) sum(n*weights)
getTotalVolume <- function(n) sum(n*volumes)
willFitInSack <- function(n) getTotalWeight(n) <= sack.weight && getTotalVolume(n) <= sack.volume

# Find all possible combination, then eliminate those that won't fit in the sack
knapsack <- expand.grid(lapply(max.items, function(n) seq.int(0, n)))
ok <- apply(knapsack, 1, willFitInSack)
knapok <- knapsack[ok,]

# Find the solutions with the highest value
vals <- apply(knapok, 1, getTotalValue)
knapok[vals == max(vals),]


setwd('~/Code/SMAI/BayesianNets')
library(e1071)

norm_vec <- function(x) sqrt(sum(x^2))

construct_kernel <- function(data_in,data_out,sequence,gamma = 0.00000002) {
  K = matrix(0,nrow(data_in),length(sequence))
  for (i in 1:nrow(data_in)) {
    for (j in 1:length(sequence)) {
      K[i,j] <- exp(-1*gamma*sum((data_in[i,] - data_out[sequence[j],])**2,na.rm = T))
    }
  }
  return(K)
}

project_points <- function(data_in,data_out,vectors) {
  sequence = 1:nrow(data_out)
  K <- construct_kernel(data_in,data_out,sequence)
  return (t(K) %*% vectors)
}

kernel_principle_components <- function(data) {
  sequence = 1:nrow(data)
  print("Constructing Kernel")
  K <- construct_kernel(data,data,sequence)
  I <- matrix(1,nrow(data),nrow(data))/nrow(data)
  K_centered <- K - I%*%K - K%*%I + I%*%K%*%I
  eig <- eigen(K_centered)
  vectors <- as.matrix(eig$vectors[,1:10])/ sqrt(eig$values[1:10])
  # final_data <- t(t(vectors) %*% t(X))
  # return(final_data)
  return(vectors)
}

kernel_linear_discriminant <- function(data,labels) {
  A <- data
  A <- as.matrix(cbind(A, labels))

  negative_sequence <- which(A[,ncol(A)] == -1)
  K_negative <- construct_kernel(data,data,negative_sequence)
  M2 <- apply(K_negative,1,function(X) (1/length(X))*sum(X))

  num_negative <- length(negative_sequence)
  K_negative <- K_negative %*% (diag(num_negative) - (1/num_negative)*matrix(1,num_negative,num_negative)) %*% t(K_negative)

  positive_sequence <- which(A[,ncol(A)] == 1)
  K_positive <- construct_kernel(data,data,positive_sequence)
  M1 <- apply(K_positive,1,function(X) (1/length(X))*sum(X))

  num_positive <- length(positive_sequence)
  K_positive <- K_positive %*% (diag(num_positive) - (1/num_positive)*matrix(1,num_positive,num_positive)) %*% t(K_positive)

  N <- K_positive + K_negative

  #print(dim(N))
  N <- N + diag(nrow(N))

  N_inv <- solve(N)

  vect <- N_inv %*% (M2-M1)
  # final_data <- t(t(vectors) %*% t(X))
  # return(final_data)
  return(vect)
}

run_KPCA <- function(data, labels,test,test_labels) {
  #vect <- kernel_linear_discriminant(data,labels)
  vect <- kernel_principle_components(data)

  a <- project_points(data,data,vect)
  #mysvm <- svm(a,labels,type='C',kernel = 'radial',gamma=0.1,cost = 100)
  mysvm <- svm(a,labels,type='C',kernel = 'radial',gamma= 0.001,cost = 10)
  #mysvm <- svm(a,labels,type='C',kernel = 'linear')
  b <- project_points(data,test,vect)
  pred <- predict(mysvm,b)
  length(which(as.vector(pred) == test_labels))
}

run_KLDA <- function(data,labels,test,test_labels) {
  vect <- kernel_linear_discriminant(data,labels)

  a <- project_points(data,data,vect)
  #mysvm <- svm(a,labels,type='C',kernel = 'radial',gamma=0.1,cost = 100)
  #mysvm <- svm(a,labels,type='C',kernel = 'radial',gamma= 0.1,cost = 10)
  mysvm <- svm(a,labels,type='C',kernel = 'linear')
  b <- project_points(data,test,vect)
  pred <- predict(mysvm,b)
  length(which(as.vector(pred) == test_labels))
}

data <- as.matrix(read.csv("Datasets/arcene_train.data",header = FALSE, sep = " ",fill = FALSE))
labels <- read.csv("Datasets/arcene_train.labels", header = FALSE, sep = " ")

test <- as.matrix(read.csv("Datasets/arcene_valid.data", header = FALSE, sep = " ",  fill = TRUE))
test_labels <- read.csv("Datasets/arcene_valid.labels", header = FALSE, sep = " ")
run_KPCA(data,labels,test,test_labels)
#run_KLDA(data,labels,test,test_labels)

#data <- as.matrix(read.csv("Datasets/gisette_train.data",header = FALSE, sep = " ",fill = FALSE))
#labels <- read.csv("Datasets/gisette_train.labels", header = FALSE, sep = " ")

#test <- as.matrix(read.csv("Datasets/gisette_valid.data", header = FALSE, sep = " ",  fill = TRUE))
#test_labels <- read.csv("Datasets/gisette_valid.labels", header = FALSE, sep = " ")
#run_KPCA(data[1:1000,1:1000],labels[1:1000,],test[1:100,1:1000],test_labels[1:100,])
#run_KLDA(data[1:1000,1:1000],labels[1:1000,],test[1:100,1:1000],test_labels[1:100,])


a<-1.14
b<-4.399E-7
cPar<-2.903E-1
Temp<- 16.369
X11()
stn<-function(SSB) {
  return(a*SSB*exp(-b*SSB+cPar*Temp))
}

SSB<-(0:50)*10^5

plot(SSB,stn(SSB))

ssb<-1.103E6
Rec<-stn(ssb)
ssb
Rec
Rec/1E6


#calculate mean and medianfro var. y2011
library(dplyr)
data = read.csv("income.csv", sep = ",")

summarise(data, mean(data$Y2009),median(data$Y2009))

#arrange Index in decreasing order
arrange(data,desc(Index))

#display 10 random obs. of variable index and state from the data set using pipe (%>%) operator
#find squareroot of 16 and add wwith 18
16%>%sqrt()%>%+19

select(data,Index,State)%>%sample_n(10)

#group data by using Index variable
group_by(data, Index)

#using pipe summerise group and sort; compute mean of vars. y2014 & y2015 by Index
#then sort the result by calculated mean var 2015

m1=mean(data$Y2014,na.rm=TRUE)
m2=mean(data$Y2015,na.rm=TRUE)
m1
m2

group_by(data,data$Index)%>%summarise(data,mean(Y2015))%>%sort(m2,decreasing = FALSE)

#mutate
m=mutate(data,difference=Y2013-Y2012)
m

#create dataframe1 which has id=c(1,2,3,4,5), var1 = c('a','b','c','d')
#var2 = c(1,1,0,0,1), var3= 5 random numbers, var4 =letters[1:5]

#df2 = id=c(1,7,3,6,8), var1 = c('z','b','k','d','i')
#var2 = c(1,2,3,0,4), var3= 5 random numbers, var4 =letters[2:6]

df1 = data.frame(id=c(1,2,3,4,5), var11 = c('a','b','c','d','e'),var12 = c(1,1,0,0,1), var13=rnorm(5),var14 =letters[1:5])
df1
df2 = data.frame(id=c(1,7,3,6,8), var21 = c('z','b','k','d','i'),var22 = c(1,2,3,0,4), var23=rnorm(5),var24 =letters[2:6])
df2

k=inner_join(df1,df2,BY=id)
k

#left_join(),right_join
#full_join(), semi_join(), anti_join()

#for reshaping data, data manipulatio in conjunction with dpyr
#data is said to be tidy if each column represents a var and each row represents obsv.
#following functions are used
library(tidyr)
data = mtcars
#use dataset mtcars
#include names of car in col. of carname
data$carname = rownames(data)
data
#converts wide data to longer format similar to melt
l=data%>%gather(key="data",value ="measure", -carname)
l
#in converts long data to wider format similar to cast
v=l%>%spread(data,measure)
v

#combines 2 or more cols. into single column
unite()

#splits 1 column in to 2 or more columns
separate()


#' Outlier
#'
#' @description return TRUE if the value is an outlier (boxplot criteria)
#'
#' @param x numeric vector
#'
#' @return Numeric vector
#' @export
#'
#' @examples
#'
#' x <- c(rnorm(10),10)
#'
#' x
#'
#' is_outlier(x)
#'

is_outlier <- function(x){

  if(is.numeric(x) == F){
    stop("x must be numeric")
  }

  q1 <- quantile(x, 0.25, na.rm = T)

  q3 <- quantile(x, 0.75, na.rm = T)

  aiq  <- q3 - q1

  li <- q1 - (1.5 * aiq)

  ls <- q3 + (1.5 * aiq)

  out <- ifelse( (x <= li) | (x >= ls), T, F)

  return(out)

}


#' @title calcLoadBSFC
#'
#' @description Calculates Brake Specific Fuel Consumption (BSFC) or Specific Oil
#' Fuel Consumption (SFOC) using a parabolic relationship with the main engine
#' load factor.
#'
#' @param loadFactor Fraction of total installed propulsive power representing
#' the instantaneous or average propulsive power (unitless) (vector of
#' numericals) (see ShipPowerModel library). If \code{NA} is supplied, the
#' baseline BSFC value is returned (i.e., the resulting emission factor will be
#' independent of engine load).
#' @param BSFC_Baseline Baseline BSFC value (g/kWh) (vector of numericals)
#'
#' @return \code{BSFC} (g/kWh) (vector of numericals)
#'
#' @references
#'International Maritime Organization. 2014. "Third IMO GHG study 2014 - Final
#'report." London: International Maritime Organization.
#'
#' \href{https://doi.org/10.5194/acp-12-2641-2012}{Jalkanen, J.-P., Johansson
#' L., Kukkonen, J., Brink, A., Kalli, J., and Stipa , T. 2012. "Extension of an
#' assessment model of ship traffic exhaust emissions for particulate matter and
#' carbon monoxide. Atmospheric Chemistry and Physics 12, no. 5.}
#'
#' @examples
#' calcLoadBSFC(c(NA, 0.5, 0.7),c(185,195,300))
#'
#' @export

calcLoadBSFC<- function(loadFactor=NULL, BSFC_Baseline){
  BSFC<-ifelse(is.na(loadFactor),
             BSFC_Baseline,
             BSFC_Baseline*(0.455*((loadFactor)^2)-0.71*loadFactor+1.28)
             )
return(BSFC)
}


### ALGORITHMS
# SVD algorithm with rank k approximation, stops when error decrease is below eps.
alg.svd <- function(df, pl=alg.svd.pl(df), debug=FALSE)
{
	mat <- matrix(pl$init, max(df$user), max(df$movie))

	# Matrix of given values
	given <- mask <- matrix(0, max(df$user), max(df$movie))
	given[(df$movie-1)*nrow(mat)+df$user] <- df$stars

	# Mask containing a '1' for each given value
	mask[(df$movie-1)*nrow(mat)+df$user] <- 1

	# Error history of length 2, initialize with dummy values making no trouble.
	errvec <- (max(df$stars) - min(df$stars)) * c(1, 1/(1-pl$eps)^2)
	while (errvec[1]/errvec[2] < 1-pl$eps) {
		# Compute error
		err <- sqrt(sum((mat*mask-given)^2) / nrow(df))
		if (debug) print(err)
		errvec <- c(err, errvec[1])
		# Then overwrite with given values ...
		mat <- mat*(1-mask)+given
		sing <- La.svd(mat, pl$k, pl$k)
		# ... and compute rank k approximation
		mat <- sing$u %*% diag(sing$d[1:pl$k],pl$k) %*% sing$v
	}

	return(mat)
}

alg.svd.pl <- function(df, init=mean(df$stars), k=1, digits=2)
	list(init=init, k=k, eps=10^-digits)

# Hazan's algorithm with target trace tr, curvature constant Cf and eps as above,
#	averaged on error history of maximum length maxhist.
alg.hazan <- function(df, pl=alg.hazan.pl(df, mean(df$stars)*(max(df$user) + max(df$movie))), debug=FALSE)
{
	n <- max(df$user); m <- max(df$movie); len <- nrow(df)

	# "Given" matrix Y we want to approximate
	Y <- matrix(0, n+m, n+m)
	Y[(df$movie-1)*(n+m)+df$user+m] <- df$stars
	Y[(df$user-1+m)*(n+m)+df$movie] <- df$stars

	# Initialize X = v*v^T with an eigenvector belonging to the greatest eigenvalue
	i <- 0; v <- power.method(Y, pl$Cf/pl$tr)
	X <- pl$tr * (v %*% t(v)) / sum(v*v)
	errvec <- (sum(ifelse(Y!=0, (X-Y)^2, 0))/len) * c(1/(1-pl$eps)^2, 1/(1-pl$eps)^4)

	decr <- 1;	# Average error decrease
	while (decr > pl$eps | i < 100) {
		# Compute error and average error decrease
		err <- sum((Y!=0) * (X-Y)^2)/len
		if (debug) print(err)
		errvec <- c(err, errvec)
		hist <- min(pl$maxhist, length(errvec))
		decr <- lm(errvec[1:hist] ~ as.numeric(1:hist))$coefficients[[2]]

		alpha <- 2/(i+2);	i <- i+1
		# Compute "symmetricized" gradient matrix of
		# f(X) = \sum_(\Omega+(0,m)) (X_ij-Y_ij)^2
		Nabla <- 2 * (Y != 0) * (X-Y)

		# Compute an eigenvector corresponding to the greatest eigenvalue
		v <- power.method(Nabla, alpha*pl$Cf/pl$tr)

		# Blend old X with tr*v*v^T
		X <- (1-alpha)*X + alpha*pl$tr * v %*% t(v)
	}

	return(X[(m+1):(n+m),1:m])
}

alg.hazan.pl <- function(df, tr, digits=2, Cf=curvature(df[c(1,2)]), maxhist=50)
	list(tr=tr, eps=10^-digits, Cf=tr^2 * Cf, maxhist=maxhist)

# "Power method" to compute an eigenvector corresponding to the greatest eigenvalue
power.method <- function(A, eps)
{
	# Start with random normalized vector
	v <- runif(dim(A)[1])
	v <- v / sqrt(sum(v*v))

	l<-2; oldl<-1;	# not "correct", but works in high dimensions
	while (l/oldl > 1 + eps) {
		v <- A %*% v
		oldl <- l; l <- sqrt(sum(v*v))
		v <- v/l
	}
	return(v)
}

# Compute lower bound for the "curvature constant" C_f
curvature <- function(df, samples=10)
{
	n <- max(df$user); m <- max(df$movie); len <- nrow(df)
	Y <- matrix(0, n+m, n+m)
	Y[(df$movie-1)*nrow(Y)+df$user+m] <- 1

	samp <- vector(mode="list", length=samples)
	for (i in 1:samples) {
		# Generate n independent vectors
		A <- matrix(rnorm((n+m)^2), nrow=n+m)
		# Normalize them
		A <- apply(A, 2, function(x) {x/sqrt(sum(x*x))})
		# Generate weights
		w <- rexp(n+m, n+m); w <- w / sum(w)
		# Generate matrix
		samp[[i]] <- A %*% (t(A)*w)
	};

	maximum <- 0;
	for (i in 1:samples)
		for (j in 1:samples) {
			diff <- sum((samp[[i]]-samp[[j]])^2 * Y)/len
			maximum <- max(maximum, diff)
		}
	return(maximum)
}

### POST PROCESSING ###
post.clamp <- function(data, rg)
{
	ifelse(data<rg[1],
		rg[1],
		ifelse(data>rg[2],
			rg[2],
			data
		)
	)
}

post.linear <- function(data, rg)
{
	old<-range(data);
	(data-old[1])/(old[2]-old[1])*(rg[2]-rg[1])+rg[1]
}

post.logistic <- function(data, rg)
{
	# Scale to [-1,1]
	data <- (2*data-(rg[1]+rg[2]))/(rg[2]-rg[1])
	# Apply logistic function with derivative 1/2 in 0.
	data <- 1/(1+exp(-2*data))
	data*(rg[2]-rg[1]) + rg[1]
}


#creates a temporal hierarchy of a count time series and reconciles it via prob prog.
library(tscount)
library(forecast)
#managing hierarchies
library(hts)
#managing temporal hierarchies
library(thief)

buildMatrix <- function() {
  A <- matrix(data = 0, nrow = length(upperIdx), ncol = length(bottomIdx))
  maxFreq <- frequency(trainHier[[1]])
  counter <- 1
  for (ii in (2:length(trainHier))){
    currentFreq <- frequency(trainHier[[ii]])
    aggregatedTs <- currentFreq
    howManyBottomToSum <- maxFreq / currentFreq
    offset <- 1
    for (jj in (1:aggregatedTs)) {
      A[counter, offset : (offset + howManyBottomToSum - 1)] <- 1
      offset <- offset + howManyBottomToSum
      counter <- counter + 1
    }
  }
  return (t(A))
}

#weekly time series with low counts from thief
autoplot(AEdemand[,13])
ts <- AEdemand[,13]
#cut the  last year of data
train <- window(ts, end = max(time(ts))-1)
trainHier <- tsaggregates(train, align = "end")
autoplot(trainHier)

test <-  window(ts, start = 2015)

testHier <-  window(ts, start = 2015)

#campy is recorded every 28 days, difficult to manage into a hierarchy.
#taken from the vignette.
# interventions <- interv_covariate(n = length(campy), tau = c(84, 100), delta = c(1, 0))
# campyfit_pois <- tsglm(campy, model = list(past_obs = 1, past_mean = 13), xreg = interventions, distr = "poisson")
# campyfit_nbin <- tsglm(campy, model = list(past_obs = 1, past_mean = 13), xreg = interventions, distr = "nbinom")
#
# #example of scoring rules
# rbind(Poisson = scoring(campyfit_pois), NegBin = scoring(campyfit_nbin))
timeseries <- Seatbelts[, "VanKilled"]
regressors <- cbind(PetrolPrice = Seatbelts[, c("PetrolPrice")],linearTrend = seq(along = timeseries)/12)
train <- window(timeseries, end = 1981 + 11/12)
regressors_train <- window(regressors, end = 1981 + 11/12)
fit_pois <- tsglm(train, model = list(past_obs = c(1, 12)), link = "log", distr = "poisson", xreg = regressors_train)

test <- window(timeseries, start = 1982)
regressors_test <- window(regressors, start=1982)

#fit_negbin <- tsglm(timeseries_until1981, model = list(past_obs = c(1, 12)), link = "log", distr = "nbinom", xreg = regressors_until1981)# #example of scoring rules
#scoring
scoring(fit_pois)


#' Calculator for ds (between subjects effect size)
#'
#' Calculator for ds (between subjects effect size)
#' @param x,y vectors of the DV for each group
#' @export
#' @examples ds_calculator()

ds_calculator <- function(group1, group2) {

  mean1 <- mean(group1)
  sd1 <- sd(group1)
  n1 <- length(group1)

  mean2 <- mean(group2)
  sd2 <- sd(group2)
  n2 <- length(group2)

  ds <- (mean1 - mean2)/
    (sqrt(
        ((n1-1)*sd1^2 + (n2-1)*sd2^2)/
          (n1 + n2 - 2)))

  return(abs(ds))
}


jose <-function(s, r,n){
y <- 0:(r-1)
 for (i in (r+1):n)
  y <- (y + s) %% i
 return(y)
}
> jose(3,1,41) # r is the number of remained prisoner.
[1] 30