# Data exploration and models for TSM

require(mgcv)
require(data.table)
require(lme4)
require(MuMIn) # for dredge
source('scripts/findPeaksGAM.r') # for location and number of peaks

#############
## functions
#############

#############
# Read in dataset
#############
dat <- fread('temp/warmingtolerance_byspecies.csv', stringsAsFactors=TRUE)

# make critical the first factor
dat$tmax_metric <- relevel(dat$tmax_metric, 'crit')

#####################
## Examine dataset
#####################
# how much data by animal type
	nrow(dat) # 406

	# Tmax raw
	i <- complete.cases(dat[,.(Realm, lat, Tmax)])
	sum(i)
	dat[i, table(Realm)]
	dat[i, table(animal.type, Realm)]
	dat[i, length(unique(Class))]
	dat[i, range(lat), by=Realm]

	# Tmax acclimation temp
	i <- complete.cases(dat[, .(Realm, lat, tmax.accsum.elev, Phylum, Class, Order, Family, Genus)])
	sum(i)
	dat[i, table(Realm)]
	dat[i, table(animal.type, Realm)]

	# Operative temperature
	i <- complete.cases(dat[, .(Realm, lat, tb_favorableGHCND95, Phylum, Class, Order, Family, Genus)])
	sum(i)
	dat[i, table(Realm)]
	dat[i, table(animal.type, Realm)]

	# TSM present time, without acclimation GHCND
	i <- complete.cases(dat[, .(Realm, lat, tmax_metric, tsm_favorableGHCND95_noacc, Phylum, Class, Order, Family, Genus)])
	sum(i)
	dat[i, table(Realm)]
	dat[i, table(animal.type, Realm)]

	# TSM present time, with acclimation GHCND
	i <- complete.cases(dat[, .(Realm, lat, tmax_metric, tsm_favorableGHCND95, Phylum, Class, Order, Family, Genus)])
	sum(i)
	dat[i, table(Realm)]
	dat[i, table(animal.type, Realm)]

# how many phyla by habitat
aggregate(list(nphyla=dat$Phylum, nclass=dat$Class, norder=dat$Family, nfamily=dat$Family, ngenera=dat$Genus), by=list(Realm=dat$Realm), FUN=function(x) length(unique(x)))

# how many classes?
	# Tmax acclimation temp
	i <- complete.cases(dat[, .(Realm, lat, tmax.accsum.elev, Phylum, Class, Order, Family, Genus)])
	sum(i)
	t(t(table(dat$Class[i])))

	# TSM present time, with acclimation
	i <- complete.cases(dat[, .(Realm, lat, tmax_metric, tsm_favorable, Phylum, Class, Order, Family, Genus)])
	table(dat$Class[i])

# latitudinal range
	# Tmax
	i <- complete.cases(dat[,.(Realm, lat, Tmax, Phylum, Class, Order, Family, Genus)])
	sum(i)
	aggregate(list(range=dat$lat[i]), by=list(habitat=dat$Realm[i]), FUN=range)

	# TSM present time, with acclimation
	i <- complete.cases(dat[, .(Realm, lat, tsm_favorableGHCND95, Phylum, Class, Order, Family, Genus)])
	sum(i)
	aggregate(list(range=dat$lat[i]), by=list(habitat=dat$Realm[i]), FUN=range)

# acclimation effect size
	# acclimation temperature
dat[Realm=='Terrestrial', summary(Tmax - tmax.accsum.elev)]
dat[Realm=='Terrestrial', sd(Tmax - tmax.accsum.elev, na.rm=TRUE)]

dat[Realm=='Marine', summary(Tmax - tmax.accsum.elev)]
dat[Realm=='Marine', sd(Tmax - tmax.accsum.elev, na.rm=TRUE)]

# odd values
	# tsm < 0
	dat[,sum(tsm_maxhr<0, na.rm=TRUE)]
	dat[tsm_favorable<0 | tsm_favorable95<0 | tsm_favorableGHCND95<0, .(Species, Genus, animal.type, Realm, lat, long_max, elev.grid, tmax_metric, Tmax, tmax.accsum.elev, thabmaxhr, tsm_maxhr, tsm_maxhr_accsum, tsm_favorable, tsm_favorable95, tsm_favorableGHCND95)]

##################################
# Average in bands and write out
##################################

# averages near equator vs. farther
	dat[lat > -10 & lat < 10 & Realm=='Terrestrial', .(mean(tsm_favorableGHCND95), sd(tsm_favorableGHCND95)/.N, .N)]
	dat[lat > -3 & lat < 3 & Realm=='Terrestrial', .(mean(tsm_favorableGHCND95), sd(tsm_favorableGHCND95)/.N, .N)]
	dat[(lat > -35 & lat < -25) & Realm=='Terrestrial', .(mean(tsm_favorableGHCND95), sd(tsm_favorableGHCND95)/.N, .N)]
	dat[(lat > 20 & lat < 30) & Realm=='Terrestrial', .(mean(tsm_favorableGHCND95), sd(tsm_favorableGHCND95)/.N, .N)]
	dat[((lat > -35 & lat < -15) | (lat > 15 & lat < 35)) & Realm=='Terrestrial', .(mean(tsm_favorableGHCND95), sd(tsm_favorableGHCND95)/.N, .N)]

# average in bands
	TSMbylat <- dat[Realm=='Terrestrial' & !is.na(tsm_favorableGHCND95), .(mean=mean(tsm_favorableGHCND95), se=sd(tsm_favorableGHCND95)/.N, n=.N), by=.(latband=floor(lat/10)*10+5)]

		# small plot to check
		setkey(TSMbylat, latband)
		TSMbylat[,plot(latband, mean, type='o', pch=16, cex=0.5)]
		TSMbylat[,arrows(latband, mean-se, latband, mean+se, length=0, angle=90, code=3)]

# write out
write.csv(TSMbylat, file='temp/warmingtolerance_bylatband_land.csv', row.names=FALSE)

#############
# Models
#############

#### projections dataframe
	newdat <- data.frame(Realm=rep(c('Marine', 'Terrestrial'), c(161,161)), lat=rep(-80:80, 2)) # for projection onto a regular vector of latitudes
		newdat$tmax_metric <- 'crit'

#### models for body temperature (Tb)
	# present-time body temperature in favorable microclimates, 95% max hr with GHCND
		i <- complete.cases(dat[,c('Realm', 'lat', 'tb_favorableGHCND95', 'Phylum', 'Class', 'Order', 'Family', 'Genus')]); sum(i); nrow(dat)
	modTbGHCND95dat <- dat[i,]
	modTbGHCND95 <- uGamm(tb_favorableGHCND95 ~ Realm + s(lat, by=Realm), random=list(Phylum=~1, Class=~1, Order=~1, Family=~1, Genus=~1), data=modTbGHCND95dat) # use uGamm instead of gamm, since former can be used with dredge. Just a wrapper function for gamm.
#		summary(modTbGHCND95$gam)

		## predictions from GAMM
		temp <- predict(modTbGHCND95$gam, newdata=newdat, se.fit=TRUE)
		newdat$tb_favorableGHCND95 <- temp$fit
		newdat$tb_favorableGHCND95se <- temp$se.fit

			# plot predictions
#			plot(tb_favorableGHCND95 ~ lat, data=newdat[newdat$Realm=='Terrestrial',], type='l', col='green', ylim=c(-10,30), xlim=c(-80,80))
#				lines(tb_favorableGHCND95 + tb_favorableGHCND95se ~ lat, data=newdat[newdat$Realm=='Terrestrial',], col='green', lty=2)
#				lines(tb_favorableGHCND95 - tb_favorableGHCND95se ~ lat, data=newdat[newdat$Realm=='Terrestrial',], col='green', lty=2)
#			lines(tb_favorableGHCND95 ~ lat, data=newdat[newdat$Realm=='Marine',], col='blue')
#				lines(tb_favorableGHCND95 - tb_favorableGHCND95se ~ lat, data=newdat[newdat$Realm=='Marine',], col='blue', lty=2)
#				lines(tb_favorableGHCND95 + tb_favorableGHCND95se ~ lat, data=newdat[newdat$Realm=='Marine',], col='blue', lty=2)
#
#			points(tb_favorableGHCND95 ~ lat, data=dat[dat$Realm=='Terrestrial',], col='green', cex=0.5)
#			points(tb_favorableGHCND95 ~ lat, data=dat[dat$Realm=='Marine',], col='blue', cex=0.5)

	# present-time body temperature in full sun, 95% max hr with GHCND
		i <- complete.cases(dat[,c('Realm', 'lat', 'tb_sunGHCND95', 'Phylum', 'Class', 'Order', 'Family', 'Genus')]); sum(i); nrow(dat)
	modTbsunGHCND95 <- uGamm(tb_sunGHCND95 ~ Realm + s(lat, by=Realm), random=list(Phylum=~1, Class=~1, Order=~1, Family=~1, Genus=~1), data=dat[i,]) # use uGamm instead of gamm, since former can be used with dredge. Just a wrapper function for gamm.
#		summary(modTbsunGHCND95$gam)

		## predictions from GAMM
		temp <- predict(modTbsunGHCND95$gam, newdata=newdat, se.fit=TRUE)
		newdat$tb_sunGHCND95 <- temp$fit
		newdat$tb_sunGHCND95se <- temp$se.fit

			# plot predictions
#			plot(tb_sunGHCND95 ~ lat, data=newdat[newdat$Realm=='Terrestrial',], type='l', col='green', ylim=c(-10,60), xlim=c(-80,80))
#				lines(tb_sunGHCND95 + tb_sunGHCND95se ~ lat, data=newdat[newdat$Realm=='Terrestrial',], col='green', lty=2)
#				lines(tb_sunGHCND95 - tb_sunGHCND95se ~ lat, data=newdat[newdat$Realm=='Terrestrial',], col='green', lty=2)
#			lines(tb_sunGHCND95 ~ lat, data=newdat[newdat$Realm=='Marine',], col='blue')
#				lines(tb_sunGHCND95 - tb_sunGHCND95se ~ lat, data=newdat[newdat$Realm=='Marine',], col='blue', lty=2)
#				lines(tb_sunGHCND95 + tb_sunGHCND95se ~ lat, data=newdat[newdat$Realm=='Marine',], col='blue', lty=2)
#
#			points(tb_sunGHCND95 ~ lat, data=dat[dat$Realm=='Terrestrial',], col='green', cex=0.5)
#			points(tb_sunGHCND95 ~ lat, data=dat[dat$Realm=='Marine',], col='blue', cex=0.5)
#
#			lines(tb_favorableGHCND95 ~ lat, data=newdat[newdat$Realm=='Marine',], col='black')
#				lines(tb_favorableGHCND95 - tb_favorableGHCND95se ~ lat, data=newdat[newdat$Realm=='Marine',], col='black', lty=2)
#				lines(tb_favorableGHCND95 + tb_favorableGHCND95se ~ lat, data=newdat[newdat$Realm=='Marine',], col='black', lty=2)

#### models for Tmax
	# Tmax (summer-acclimated)
		i <- complete.cases(dat[,c('Realm', 'lat', 'tmax.accsum.elev', 'Phylum', 'Class', 'Order', 'Family', 'Genus')]); sum(i); nrow(dat)
	modTmaxdat <- dat[i,]
	modTmax <- uGamm(tmax.accsum.elev ~ Realm + tmax_metric + s(lat, by=Realm), random=list(Phylum=~1, Class=~1, Order=~1, Family=~1, Genus=~1), data=modTmaxdat) # use uGamm instead of gamm, since former can be used with dredge. Just a wrapper function for gamm.
#		summary(modTmax$gam)

		## predictions from GAMM
		temp <- predict(modTmax$gam, newdata=newdat, se.fit=TRUE)
		newdat$tmax <- temp$fit
		newdat$tmaxse <- temp$se.fit

			# plot predictions
#		plot(tmax ~ lat, data=newdat[newdat$Realm=='Terrestrial',], type='l', col='green', ylim=c(10,50), xlim=c(-80,80))
#			lines(tmax + tmaxse ~ lat, data=newdat[newdat$Realm=='Terrestrial',], col='green', lty=2)
#			lines(tmax - tmaxse ~ lat, data=newdat[newdat$Realm=='Terrestrial',], col='green', lty=2)
#		lines(tmax ~ lat, data=newdat[newdat$Realm=='Marine',], col='blue')
#			lines(tmax - tmaxse ~ lat, data=newdat[newdat$Realm=='Marine',], col='blue', lty=2)
#			lines(tmax + tmaxse ~ lat, data=newdat[newdat$Realm=='Marine',], col='blue', lty=2)
#
#		points(tmax.accsum.elev ~ lat, data=dat[dat$Realm=='Terrestrial',], col='green', cex=0.5)
#		points(tmax.accsum.elev ~ lat, data=dat[dat$Realm=='Marine',], col='blue', cex=0.5)

	# Tmax with species-specific ARR data
	i <- complete.cases(dat[,c('Realm', 'lat', 'tmax.accsumbyspp.elev', 'Phylum', 'Class', 'Order', 'Family', 'Genus')]); sum(i); nrow(dat)
	modTmaxARRbyspp <- uGamm(tmax.accsumbyspp.elev ~ Realm + tmax_metric + s(lat, by=Realm), random=list(Phylum=~1, Class=~1, Order=~1, Family=~1, Genus=~1), data=dat[i,])
#		summary(modTmaxARRbyspp$gam)

		## predictions from GAMM
		temp <- predict(modTmaxARRbyspp$gam, newdata=newdat, se.fit=TRUE)
		newdat$tmaxARRbyspp <- temp$fit
		newdat$tmaxARRbysppse <- temp$se.fit

#### models for TSM

	# present-time TSM (annual, no acclimation)
		# gamm
		i <- complete.cases(dat[,c('Realm', 'lat', 'tmax_metric', 'tsm_ann_elev', 'Phylum', 'Class', 'Order', 'Family', 'Genus')]); sum(i); nrow(dat)
	modTSMann <- uGamm(tsm_ann_elev ~ Realm + tmax_metric + s(lat, by=Realm), random=list(Phylum=~1, Class=~1, Order=~1, Family=~1, Genus=~1), data=dat[i,]) # use uGamm instead of gamm, since former can be used with dredge. Just a wrapper function for gamm.
#		summary(modTSMann$gam)

		## predictions from GAMM
		temp <- predict(modTSMann$gam, newdata=newdat, se.fit=TRUE)
		newdat$tsm_ann <- temp$fit
		newdat$tsm_annse <- temp$se.fit

			# plot predictions
#			plot(tsm_ann ~ lat, data=newdat[newdat$Realm=='Terrestrial' & newdat$abslat<50,], type='l', col='green', ylim=c(-10,30), xlim=c(-80,80))
#				lines(tsm_ann + tsm_annse ~ lat, data=newdat[newdat$Realm=='Terrestrial' & newdat$abslat<50,], col='green', lty=2)
#				lines(tsm_ann - tsm_annse ~ lat, data=newdat[newdat$Realm=='Terrestrial' & newdat$abslat<50,], col='green', lty=2)
#			lines(tsm_ann ~ lat, data=newdat[newdat$Realm=='Marine',], col='blue')
#				lines(tsm_ann - tsm_annse ~ lat, data=newdat[newdat$Realm=='Marine',], col='blue', lty=2)
#				lines(tsm_ann + tsm_annse ~ lat, data=newdat[newdat$Realm=='Marine',], col='blue', lty=2)
#
#			points(tsm_ann_elev ~ lat, data=dat[dat$Realm=='Terrestrial',], col='green', cex=0.5)
#			points(tsm_ann ~ lat, data=dat[dat$Realm=='Marine',], col='blue', cex=0.5)

	# present-time TSM (summer)
		# gamm
		i <- complete.cases(dat[,c('Realm', 'lat', 'tmax_metric', 'tsm_sum_elev', 'Phylum', 'Class', 'Order', 'Family', 'Genus')]); sum(i); nrow(dat)
	modTSMsum <- uGamm(tsm_sum_elev ~ Realm + tmax_metric + s(lat, by=Realm), random=list(Phylum=~1, Class=~1, Order=~1, Family=~1, Genus=~1), data=dat[i,]) # use uGamm instead of gamm, since former can be used with dredge. Just a wrapper function for gamm.
#		summary(modTSMsum$gam)

		## predictions from GAMM
		temp <- predict(modTSMsum$gam, newdata=newdat, se.fit=TRUE)
		newdat$tsm_sum <- temp$fit
		newdat$tsm_sumse <- temp$se.fit

			# plot predictions
#			plot(tsm_sum ~ lat, data=newdat[newdat$Realm=='Terrestrial' & newdat$abslat<50,], type='l', col='green', ylim=c(-10,30), xlim=c(-80,80))
#				lines(tsm_sum + tsm_sumse ~ lat, data=newdat[newdat$Realm=='Terrestrial' & newdat$abslat<50,], col='green', lty=2)
#				lines(tsm_sum - tsm_sumse ~ lat, data=newdat[newdat$Realm=='Terrestrial' & newdat$abslat<50,], col='green', lty=2)
#			lines(tsm_sum ~ lat, data=newdat[newdat$Realm=='Marine',], col='blue')
#				lines(tsm_sum - tsm_sumse ~ lat, data=newdat[newdat$Realm=='Marine',], col='blue', lty=2)
#				lines(tsm_sum + tsm_sumse ~ lat, data=newdat[newdat$Realm=='Marine',], col='blue', lty=2)
#
#			points(tsm_sum_elev ~ lat, data=dat[dat$Realm=='Terrestrial',], col='green', cex=0.5)
#			points(tsm_sum_elev ~ lat, data=dat[dat$Realm=='Marine',], col='blue', cex=0.5)

	# present-time TSM (hottest month)
		# gamm
		i <- complete.cases(dat[,c('Realm', 'lat', 'tmax_metric', 'tsm_maxmo_elev', 'Phylum', 'Class', 'Order', 'Family', 'Genus')]); sum(i); nrow(dat)
	modTSMmaxmo <- uGamm(tsm_maxmo_elev ~ Realm + tmax_metric + s(lat, by=Realm), random=list(Phylum=~1, Class=~1, Order=~1, Family=~1, Genus=~1), data=dat[i,]) # use uGamm instead of gamm, since former can be used with dredge. Just a wrapper function for gamm.
#		summary(modTSMmaxmo$gam)

		## predictions from GAMM
		temp <- predict(modTSMmaxmo$gam, newdata=newdat, se.fit=TRUE)
		newdat$tsm_maxmo <- temp$fit
		newdat$tsm_maxmose <- temp$se.fit

			# plot predictions
#			plot(tsm_maxmo ~ lat, data=newdat[newdat$Realm=='Terrestrial' & newdat$abslat<50,], type='l', col='green', ylim=c(-10,30), xlim=c(-80,80))
#				lines(tsm_maxmo + tsm_maxmose ~ lat, data=newdat[newdat$Realm=='Terrestrial' & newdat$abslat<50,], col='green', lty=2)
#				lines(tsm_maxmo - tsm_maxmose ~ lat, data=newdat[newdat$Realm=='Terrestrial' & newdat$abslat<50,], col='green', lty=2)
#			lines(tsm_maxmo ~ lat, data=newdat[newdat$Realm=='Marine',], col='blue')
#				lines(tsm_maxmo - tsm_maxmose ~ lat, data=newdat[newdat$Realm=='Marine',], col='blue', lty=2)
#				lines(tsm_maxmo + tsm_maxmose ~ lat, data=newdat[newdat$Realm=='Marine',], col='blue', lty=2)
#
#			points(tsm_maxmo_elev ~ lat, data=dat[dat$Realm=='Terrestrial',], col='green', cex=0.5)
#			points(tsm_maxmo_elev ~ lat, data=dat[dat$Realm=='Marine',], col='blue', cex=0.5)

	# present-time TSM in exposed microclimates (95% hottest hour GHCND Tb)
	# with summer acclimation corrections
		# gamm
		i <- complete.cases(dat[,c('Realm', 'lat', 'tmax_metric', 'tsm_exposedGHCND95', 'Phylum', 'Class', 'Order', 'Family', 'Genus')]); sum(i); nrow(dat)
	modTSMexp <- uGamm(tsm_exposedGHCND95 ~ Realm + tmax_metric + s(lat, by=Realm), random=list(Phylum=~1, Class=~1, Order=~1, Family=~1, Genus=~1), data=dat[i,]) # use uGamm instead of gamm, since former can be used with dredge. Just a wrapper function for gamm.
#		summary(modTSMexp$lme)
#		summary(modTSMexp$gam)

		## predictions from GAMM
		temp <- predict(modTSMexp$gam, newdata=newdat, se.fit=TRUE)
		newdat$tsm_exposedGHCND95 <- temp$fit
		newdat$tsm_exposedGHCND95se <- temp$se.fit

			# plot predictions
#			plot(tsm_exposed ~ lat, data=newdat[newdat$Realm=='Terrestrial' & newdat$abslat<50,], type='l', col='green', ylim=c(-25,20), xlim=c(-80,80))
#				lines(tsm_exposed + tsm_exposedse ~ lat, data=newdat[newdat$Realm=='Terrestrial' & newdat$abslat<50,], col='green', lty=2)
#				lines(tsm_exposed - tsm_exposedse ~ lat, data=newdat[newdat$Realm=='Terrestrial' & newdat$abslat<50,], col='green', lty=2)
#			lines(tsm_exposed ~ lat, data=newdat[newdat$Realm=='Marine',], col='blue')
#				lines(tsm_exposed - tsm_exposedse ~ lat, data=newdat[newdat$Realm=='Marine',], col='blue', lty=2)
#				lines(tsm_exposed + tsm_exposedse ~ lat, data=newdat[newdat$Realm=='Marine',], col='blue', lty=2)
#
#			points(tsm_exposed ~ lat, data=dat[dat$Realm=='Terrestrial',], col='green', cex=0.5)
#			points(tsm_exposed ~ lat, data=dat[dat$Realm=='Marine',], col='blue', cex=0.5)

	# present-time TSM in favorable microclimates (95% hottest hour with GHCND Tb) (WITH acclimation, Marine BT)
		# gamm
		i <- complete.cases(dat[,c('Realm', 'lat', 'tmax_metric', 'tsm_favorableGHCND95', 'Phylum', 'Class', 'Order', 'Family', 'Genus')]); sum(i); nrow(dat)
	modGHCND95dat <- dat[i,]
	modGHCND95 <- uGamm(tsm_favorableGHCND95 ~ Realm + tmax_metric + s(lat, by=Realm), random=list(Phylum=~1, Class=~1, Order=~1, Family=~1, Genus=~1), data=modGHCND95dat, control=lmeControl(niterEM=0, msMaxIter=100)) # use uGamm instead of gamm, since former can be used with dredge. Just a wrapper function for gamm.
#		summary(modGHCND95$lme)
#		summary(modGHCND95$gam)

		## predictions from GAMM
		temp <- predict(modGHCND95$gam, newdata=newdat, se.fit=TRUE)
		newdat$tsm_favorableGHCND95 <- temp$fit
		newdat$tsm_favorableGHCND95se <- temp$se.fit

			# plot predictions
#			plot(tsm_favorableGHCND95 ~ lat, data=newdat[newdat$Realm=='Terrestrial',], type='l', col='green', ylim=c(-10,30), xlim=c(-80,80))
#				lines(tsm_favorableGHCND95 + tsm_favorableGHCND95se ~ lat, data=newdat[newdat$Realm=='Terrestrial',], col='green', lty=2)
#				lines(tsm_favorableGHCND95 - tsm_favorableGHCND95se ~ lat, data=newdat[newdat$Realm=='Terrestrial',], col='green', lty=2)
#			lines(tsm_favorableGHCND95 ~ lat, data=newdat[newdat$Realm=='Marine',], col='blue')
#				lines(tsm_favorableGHCND95 - tsm_favorableGHCND95se ~ lat, data=newdat[newdat$Realm=='Marine',], col='blue', lty=2)
#				lines(tsm_favorableGHCND95 + tsm_favorableGHCND95se ~ lat, data=newdat[newdat$Realm=='Marine',], col='blue', lty=2)
#
#			points(tsm_favorableGHCND95 ~ lat, data=dat[i & Realm=='Terrestrial',], col='green', cex=0.5)
#			points(tsm_favorableGHCND95 ~ lat, data=dat[i & Realm=='Marine',], col='blue', cex=0.5)
#
#				dat[i & Realm=='Marine' & demers_pelag=='pelagic' & big==TRUE & mobility=='swim', points(tsm_favorableGHCND95 ~ lat, col='red', cex=0.5)]
#
#
#			lines(tsm_favorable95 ~ lat, data=newdat[newdat$Realm=='Terrestrial',], col='red')
#				lines(tsm_favorable95 - tsm_favorable95se ~ lat, data=newdat[newdat$Realm=='Terrestrial',], col='red', lty=2)
#				lines(tsm_favorable95 + tsm_favorable95se ~ lat, data=newdat[newdat$Realm=='Terrestrial',], col='red', lty=2)
#
#
#			datorig <- fread('temp/warmingtolerance_byspecies_2017-12-19.csv')
#			# use 95% warmest hour for TSMs. favorable microclimates (shade or wet skin + behavioral thermoregulation of 10degC)
#			datorig[, tsm_favorable95_10 := as.numeric(rep(NA, .N))]
#			datorig[habitat=='terrestrial' & animal.type!='amphibian', tsm_favorable95_10 := tsm_NM_2m_airshade95_accsum.elev]
#			datorig[habitat=='terrestrial' & animal.type=='amphibian', tsm_favorable95_10 := tsm_NM_shade_body_wet95_accsum.elev]
#			datorig[habitat=='marine', tsm_favorable95_10 := tsm_95hr_marineBT10_accsum]
#
#			points(tsm_favorable95_10 ~ lat, data=datorig[habitat=='marine',], col='red', cex=0.3, pch=16)

		# minimum marine TSM vs. minimum terrestrial TSM
		min(newdat$tsm_favorableGHCND95[newdat$Realm=='Terrestrial']) - min(newdat$tsm_favorableGHCND95[newdat$Realm=='Marine'])

	# Species-specific ARR data: present-time TSM in favorable microclimates (95% hottest hour with GHCND Tb) (WITH acclimation, Marine BT)
	i <- complete.cases(dat[,c('Realm', 'lat', 'tmax_metric', 'tsm_favorableGHCND95byspp', 'Phylum', 'Class', 'Order', 'Family', 'Genus')]); sum(i); nrow(dat)
	modGHCND95ARRbysppdat <- dat[i,]
	modGHCND95ARRbyspp <- uGamm(tsm_favorableGHCND95byspp ~ Realm + tmax_metric + s(lat, by=Realm), random=list(Phylum=~1, Class=~1, Order=~1, Family=~1, Genus=~1), data=modGHCND95ARRbysppdat, control=lmeControl(niterEM=50, msMaxIter=1000))
#		summary(modGHCND95ARRbyspp$gam)

	# present-time TSM in favorable microclimates (95% hottest hour GHCND Tb) (with acclimation, WITHOUT marine behavioral thermoregulation)
		# gamm
		i <- complete.cases(dat[,c('Realm', 'lat', 'tmax_metric', 'tsm_favorableGHCND95_nomarineBT', 'Phylum', 'Class', 'Order', 'Family', 'Genus')]); sum(i); nrow(dat)
	modnoMBT <- uGamm(tsm_favorableGHCND95_nomarineBT ~ Realm + tmax_metric + s(lat, by=Realm), random=list(Phylum=~1, Class=~1, Order=~1, Family=~1, Genus=~1), data=dat[i,], control=lmeControl(niterEM=0, msMaxIter=100))
#		summary(modnoMBT$gam)

		## predictions from GAMM
		temp <- predict(modnoMBT$gam, newdata=newdat, se.fit=TRUE)
		newdat$tsm_favorableGHCND95_nomarineBT <- temp$fit
		newdat$tsm_favorableGHCND95_nomarineBTse <- temp$se.fit

			# plot predictions. TSMs with thermoregulation in marine animals in red.
#			plot(tsm_favorableGHCND95_nomarineBT ~ lat, data=newdat[newdat$Realm=='Terrestrial',], type='l', col='green', ylim=c(-10,30), xlim=c(-80,80))
#				lines(tsm_favorableGHCND95_nomarineBT + tsm_favorableGHCND95_nomarineBTse ~ lat, data=newdat[newdat$Realm=='Terrestrial',], col='green', lty=2)
#				lines(tsm_favorableGHCND95_nomarineBT - tsm_favorableGHCND95_nomarineBTse ~ lat, data=newdat[newdat$Realm=='Terrestrial',], col='green', lty=2)
#			lines(tsm_favorableGHCND95_nomarineBT ~ lat, data=newdat[newdat$Realm=='Marine',], col='red')
#				lines(tsm_favorableGHCND95_nomarineBT - tsm_favorableGHCND95_nomarineBTse ~ lat, data=newdat[newdat$Realm=='Marine',], col='red', lty=2) #w/out marine BT in red
#				lines(tsm_favorableGHCND95_nomarineBT + tsm_favorableGHCND95_nomarineBTse ~ lat, data=newdat[newdat$Realm=='Marine',], col='red', lty=2)
#
#			# overlay with marine BT
#			lines(tsm_favorableGHCND95 ~ lat, data=newdat[newdat$Realm=='Marine',], col='blue')
#				lines(tsm_favorableGHCND95 - tsm_favorableGHCND95se ~ lat, data=newdat[newdat$Realm=='Marine',], col='blue', lty=2)
#				lines(tsm_favorableGHCND95 + tsm_favorableGHCND95se ~ lat, data=newdat[newdat$Realm=='Marine',], col='blue', lty=2)
#
#			points(tsm_favorableGHCND95_nomarineBT ~ lat, data=dat[dat$Realm=='Terrestrial',], col='green', cex=0.5)
#			points(tsm_favorableGHCND95_nomarineBT ~ lat, data=dat[dat$Realm=='Marine',], col='blue', cex=0.5)

	# present-time TSM in favorable microclimates (95% hottest hour with GHCND Tb) (WITH acclimation, MOREs Marine BT)
		# gamm
		i <- complete.cases(dat[,c('Realm', 'lat', 'tmax_metric', 'tsm_favorableGHCND95_marBTmore', 'Phylum', 'Class', 'Order', 'Family', 'Genus')]); sum(i); nrow(dat)
	modGHCND95_marBTmoredat <- dat[i,]
	modGHCND95_marBTmore <- uGamm(tsm_favorableGHCND95_marBTmore ~ Realm + tmax_metric + s(lat, by=Realm), random=list(Phylum=~1, Class=~1, Order=~1, Family=~1, Genus=~1), data=modGHCND95_marBTmoredat, control=lmeControl(niterEM=0, msMaxIter=100)) # use uGamm instead of gamm, since former can be used with dredge. Just a wrapper function for gamm.
#		summary(modGHCND95_marBTmore$gam)
#			summary(modGHCND95$gam) # to compare

	# present-time TSM in favorable microclimates (95% hottest hour with GHCND Tb) (WITH acclimation, LESS Marine BT)
		# gamm
		i <- complete.cases(dat[,c('Realm', 'lat', 'tmax_metric', 'tsm_favorableGHCND95_marBTless', 'Phylum', 'Class', 'Order', 'Family', 'Genus')]); sum(i); nrow(dat)
	modGHCND95_marBTlessdat <- dat[i,]
	modGHCND95_marBTless <- uGamm(tsm_favorableGHCND95_marBTless ~ Realm + tmax_metric + s(lat, by=Realm), random=list(Phylum=~1, Class=~1, Order=~1, Family=~1, Genus=~1), data=modGHCND95_marBTlessdat, control=lmeControl(niterEM=0, msMaxIter=100)) # use uGamm instead of gamm, since former can be used with dredge. Just a wrapper function for gamm.
#		summary(modGHCND95_marBTless$gam)
#			summary(modGHCND95_marBTmore$gam) # to compare
#			summary(modGHCND95$gam) # to compare

	# present-time TSM in favorable microclimates (95% hottest hour, GHCND, WITH marine BT)
	# NO acclimation corrections
		# gamm
		i <- complete.cases(dat[,c('Realm', 'lat', 'tmax_metric', 'tsm_favorableGHCND95_noacc', 'Phylum', 'Class', 'Order', 'Family', 'Genus')]); sum(i); nrow(dat)
	modTSMfav_noaccdat <- dat[i,]
	modTSMfav_noacc <- uGamm(tsm_favorableGHCND95_noacc ~ Realm + tmax_metric + s(lat, by=Realm), random=list(Phylum=~1, Class=~1, Order=~1, Family=~1, Genus=~1), data=modTSMfav_noaccdat) # use uGamm instead of gamm, since former can be used with dredge. Just a wrapper function for gamm.
#		summary(modTSMfav_noacc$gam)

		## predictions from GAMM
		temp <- predict(modTSMfav_noacc$gam, newdata=newdat, se.fit=TRUE)
		newdat$tsm_favorable_noacc <- temp$fit
		newdat$tsm_favorable_noaccse <- temp$se.fit

			# plot predictions
#			plot(tsm_favorable_noacc ~ lat, data=newdat[newdat$Realm=='Terrestrial' & newdat$abslat<50,], type='l', col='green', ylim=c(-10,30), xlim=c(-80,80))
#				lines(tsm_favorable_noacc + tsm_favorable_noaccse ~ lat, data=newdat[newdat$Realm=='Terrestrial' & newdat$abslat<50,], col='green', lty=2)
#				lines(tsm_favorable_noacc - tsm_favorable_noaccse ~ lat, data=newdat[newdat$Realm=='Terrestrial' & newdat$abslat<50,], col='green', lty=2)
#			lines(tsm_favorable_noacc ~ lat, data=newdat[newdat$Realm=='Marine',], col='blue')
#				lines(tsm_favorable_noacc - tsm_favorable_noaccse ~ lat, data=newdat[newdat$Realm=='Marine',], col='blue', lty=2)
#				lines(tsm_favorable_noacc + tsm_favorable_noaccse ~ lat, data=newdat[newdat$Realm=='Marine',], col='blue', lty=2)
#
#			points(tsm_favorable_noacc ~ lat, data=dat[dat$Realm=='Terrestrial',], col='green', cex=0.5)
#			points(tsm_favorable_noacc ~ lat, data=dat[dat$Realm=='Marine',], col='blue', cex=0.5)

	# present-time TSM in favorable microclimates (95% hottest hour, GHCND, WITH marine BT)
	# NO acclimation corrections, but acclimation temperature included as a fixed effect
		# gamm
		i <- complete.cases(dat[,c('Realm', 'lat', 'tmax_metric', 'tsm_favorableGHCND95_noacc', 'tmax_acc', 'Phylum', 'Class', 'Order', 'Family', 'Genus')]); sum(i); nrow(dat)
	modTSMfav_acctermdat <- dat[i,]
	modTSMfav_accterm <- uGamm(tsm_favorableGHCND95_noacc ~ Realm + tmax_metric + tmax_acc + s(lat, by=Realm), random=list(Phylum=~1, Class=~1, Order=~1, Family=~1, Genus=~1), data=modTSMfav_acctermdat) # use uGamm instead of gamm, since former can be used with dredge. Just a wrapper function for gamm.
#		summary(modTSMfav_accterm$gam)

# Write out predictions
write.csv(newdat, file='temp/warmingtolerance_bylatlon.csv', row.names=FALSE)

#############################
## Calculate peak locations
## (need models from above)
#############################

	# present-time body temperature in favorable microclimates, 95% max hr with GHCND
		# how many peaks?
		peaksmeanTbGHCND95_terr <- findPeaksGAM(modTbGHCND95$gam, newdat[newdat$Realm=='Terrestrial',], xvar='lat', xtol=4) # from the main prediction
			peaksmeanTbGHCND95_terr$npeaks
			peaksmeanTbGHCND95_terr$peaklocs
		peaksTbGHCND95_terr <- findPeaksGAM_CI(mod=modTbGHCND95$gam, newdat=newdat[newdat$Realm=='Terrestrial',], n=1000, xvar='lat', xtol=4) # xtol sets lat window to 4° in each direction
		peaksmeanTbGHCND95_mar <- findPeaksGAM(modTbGHCND95$gam, newdat[newdat$Realm=='Marine',], xvar='lat', xtol=4) # from the main prediction
		peaksTbGHCND95_mar <- findPeaksGAM_CI(mod=modTbGHCND95$gam, newdat=newdat[newdat$Realm=='Marine',], n=1000, xvar='lat', xtol=4)

		# write out
		saveRDS(peaksTbGHCND95_terr, file='temp/peaks_modTbGHCND95_terr.rds')
		saveRDS(peaksTbGHCND95_mar, file='temp/peaks_modTbGHCND95_mar.rds')

#### models for Tmax
	# Tmax (summer-acclimated)
		# how many peaks?
		peaksmeanTmax_terr <- findPeaksGAM(modTmax$gam, newdat[newdat$Realm=='Terrestrial',], xvar='lat', xtol=4) # from the main prediction
			peaksmeanTmax_terr$npeaks
			peaksmeanTmax_terr$peaklocs
		peaksTmax_terr <- findPeaksGAM_CI(mod=modTmax$gam, newdat=newdat[newdat$Realm=='Terrestrial',], n=1000, xvar='lat', xtol=4) # xtol sets lat window to 4° in each direction
		peaksmeanTmax_mar <- findPeaksGAM(modTmax$gam, newdat[newdat$Realm=='Marine',], xvar='lat', xtol=4) # from the main prediction
		peaksTmax_mar <- findPeaksGAM_CI(mod=modTmax$gam, newdat=newdat[newdat$Realm=='Marine',], n=1000, xvar='lat', xtol=4)

		# write out
		saveRDS(peaksTmax_terr, file='temp/peaks_modTmax_terr.rds')
		saveRDS(peaksTmax_mar, file='temp/peaks_modTmax_mar.rds')

#### models for TSM
	# present-time TSM in favorable microclimates (95% hottest hour with GHCND Tb) (WITH acclimation, Marine BT)
		# how many valleys?
		peaksmeanTSM_favorableGHCND95_terr <- findPeaksGAM(modGHCND95$gam, newdat[newdat$Realm=='Terrestrial',], xvar='lat', xtol=4, findmaxima=FALSE) # from the main prediction
			peaksmeanTSM_favorableGHCND95_terr$npeaks
			peaksmeanTSM_favorableGHCND95_terr$peaklocs
		peaksTSM_favorableGHCND95_terr <- findPeaksGAM_CI(mod=modGHCND95$gam, newdat=newdat[newdat$Realm=='Terrestrial',], n=1000, xvar='lat', xtol=4, findmaxima=FALSE) # xtol sets lat window to 4° in each direction
		peaksmeanTSM_favorableGHCND95_mar <- findPeaksGAM(modGHCND95$gam, newdat[newdat$Realm=='Marine',], xvar='lat', xtol=4, findmaxima=FALSE)
		peaksTSM_favorableGHCND95_mar <- findPeaksGAM_CI(mod=modGHCND95$gam, newdat=newdat[newdat$Realm=='Marine',], n=1000, xvar='lat', xtol=4, findmaxima=FALSE)

		# write out
		saveRDS(peaksTSM_favorableGHCND95_terr, file='temp/peaks_modGHCND95_terr.rds')
		saveRDS(peaksTSM_favorableGHCND95_mar, file='temp/peaks_modGHCND95_mar.rds')

#############################
## Calculate RVI
## (need models from above)
#############################

#### models for operative temperature (Te)
	# present-time body temperature in favorable microclimates, 95% max hr with GHCND
		# fit all subsets
		options(na.action = "na.fail")
		modTbGHCND95s <- dredge(modTbGHCND95, beta=FALSE, evaluate=TRUE, rank='AICc', trace=1)
#		subset(modTbGHCND95s, delta < 6)

		modavgTbGHCND95 <- model.avg(modTbGHCND95s)
#		summary(modavgTEGHCND95)

#### models for Tmax
	# Tmax (summer-acclimated)
		# fit all subsets
		options(na.action = "na.fail")
		modTmaxs <- dredge(modTmax, beta=FALSE, evaluate=TRUE, rank='AICc', trace=1)
#		subset(modTmaxs)

		modavgTmax <- model.avg(modTmaxs)
		#summary(modavgTmax)

#### models for TSM
	# present-time TSM in favorable microclimates (95% hottest hour with GHCND) (WITH acclimation, Marine BT)
		# fit all subsets
		options(na.action = "na.fail")
		modGHCND95s <- dredge(modGHCND95, beta=FALSE, evaluate=TRUE, rank='AICc', trace=1)
#		subset(modGHCND95s, delta < 6)

		modavgGHCND95 <- model.avg(modGHCND95s)
#		summary(modavgGHCND95)

	# Species-specific ARR data: present-time TSM in favorable microclimates (95% hottest hour with GHCND Tb) (WITH acclimation, Marine BT)
		# fit all subsets
		options(na.action = "na.fail")
		modGHCND95ARRbyspps <- dredge(modGHCND95ARRbyspp, beta=FALSE, evaluate=TRUE, rank='AICc', trace=1)
#		subset(modGHCND95ARRbyspps, delta < 6)

		modavgGHCND95ARRbyspp <- model.avg(modGHCND95ARRbyspps)
#		summary(modavgGHCND95ARRbyspp)

	# present-time TSM in favorable microclimates (95% hottest hour with GHCND) (with acclimation, MORE Marine BT)
		# fit all subsets
		options(na.action = "na.fail")
		modGHCND95_marBTmores <- dredge(modGHCND95_marBTmore, beta=FALSE, evaluate=TRUE, rank='AICc', trace=1)
#		subset(modGHCND95_marBTmores, delta < 6)

		modavgGHCND95_marBTmore <- model.avg(modGHCND95_marBTmores)
#		summary(modavgGHCND95_marBTmore)

	# present-time TSM in favorable microclimates (95% hottest hour with GHCND) (with acclimation, LESS Marine BT)
		# fit all subsets
		options(na.action = "na.fail")
		modGHCND95_marBTlesss <- dredge(modGHCND95_marBTless, beta=FALSE, evaluate=TRUE, rank='AICc', trace=1)
#		subset(modGHCND95_marBTlesss, delta < 6)

		modavgGHCND95_marBTless <- model.avg(modGHCND95_marBTlesss)
#		summary(modavgGHCND95_marBTless)

	# present-time TSM in favorable microclimates (95% hottest hour, GHCND, WITH marine BT)
	# NO acclimation corrections
		# fit all subsets
		options(na.action = "na.fail")
		modTSMfav_noaccs <- dredge(modTSMfav_noacc, beta=FALSE, evaluate=TRUE, rank='AICc', trace=1)
#		subset(modTSMfav_noaccs, delta < 6)

		modavgTSMfav_noacc <- model.avg(modTSMfav_noaccs)
#		summary(modavgTSMfav_noacc)

	# present-time TSM in favorable microclimates (95% hottest hour, GHCND, WITH marine BT)
	# NO acclimation corrections, but acclimation temperature included as a fixed effect
		# fit all subsets
		options(na.action = "na.fail")
		modTSMfav_accterms <- dredge(modTSMfav_accterm, beta=FALSE, evaluate=TRUE, rank='AICc', trace=1)
#		subset(modTSMfav_accterms, delta < 6)

		modavgTSMfav_accterm <- model.avg(modTSMfav_accterms)
#		summary(modavgTSMfav_accterm)

####################################################
### Write out table of peaks and valleys in GAMMS
####################################################
out <- data.frame(Variable=c('T_b terrestrial', 'T_b marine', 'T_max terrestrial', 'T_max marine', 'TSM_favorable terrestrial', 'TSM_favorable marine'), Peak1=character(6), Peak2=character(6), Peak3=character(6), stringsAsFactors=FALSE)

# calculate quantiles
qTbGHCND95_terr1 <- quantile(sapply(peaksTbGHCND95_terr$peaklocs, FUN=function(x, min=-50, max=0){ret <- x[x>min & x<max]; ifelse(length(ret)==1, ret, NA)}), probs=c(0.025, 0.975), na.rm=TRUE)
qTbGHCND95_terr2 <- quantile(sapply(peaksTbGHCND95_terr$peaklocs, FUN=function(x, min=0, max=50){ret <- x[x>min & x<max]; ifelse(length(ret)==1, ret, NA)}), probs=c(0.025, 0.975), na.rm=TRUE)
qTbGHCND95_mar1 <- quantile(sapply(peaksTbGHCND95_mar$peaklocs, FUN=function(x, min=-50, max=50){ret <- x[x>min & x<max]; ifelse(length(ret)==1, ret, NA)}), probs=c(0.025, 0.975), na.rm=TRUE)

qTmax_terr1 <- quantile(sapply(peaksTmax_terr$peaklocs, FUN=function(x, min=-50, max=0){ret <- x[x>min & x<max]; ifelse(length(ret)==1, ret, NA)}), probs=c(0.025, 0.975), na.rm=TRUE)
qTmax_terr2 <- quantile(sapply(peaksTmax_terr$peaklocs, FUN=function(x, min=0, max=30){ret <- x[x>min & x<max]; ifelse(length(ret)==1, ret, NA)}), probs=c(0.025, 0.975), na.rm=TRUE)
qTmax_mar1 <- quantile(sapply(peaksTmax_mar$peaklocs, FUN=function(x, min=-50, max=-30){ret <- x[x>min & x<max]; ifelse(length(ret)==1, ret, NA)}), probs=c(0.025, 0.975), na.rm=TRUE)
qTmax_mar2 <- quantile(sapply(peaksTmax_mar$peaklocs, FUN=function(x, min=-30, max=0){ret <- x[x>min & x<max]; ifelse(length(ret)==1, ret, NA)}), probs=c(0.025, 0.975), na.rm=TRUE)
qTmax_mar3 <- quantile(sapply(peaksTmax_mar$peaklocs, FUN=function(x, min=0, max=30){ret <- x[x>min & x<max]; ifelse(length(ret)==1, ret, NA)}), probs=c(0.025, 0.975), na.rm=TRUE)

qTSM_favorableGHCND95_terr1 <- quantile(sapply(peaksTSM_favorableGHCND95_terr$peaklocs, FUN=function(x, min=-50, max=0){ret <- x[x>min & x<max]; ifelse(length(ret)==1, ret, NA)}), probs=c(0.025, 0.975), na.rm=TRUE)
qTSM_favorableGHCND95_terr2 <- quantile(sapply(peaksTSM_favorableGHCND95_terr$peaklocs, FUN=function(x, min=0, max=50){ret <- x[x>min & x<max]; ifelse(length(ret)==1, ret, NA)}), probs=c(0.025, 0.975), na.rm=TRUE)
qTSM_favorableGHCND95_mar1 <- quantile(sapply(peaksTSM_favorableGHCND95_mar$peaklocs, FUN=function(x, min=-30, max=50){ret <- x[x>min & x<max]; ifelse(length(ret)==1, ret, NA)}), probs=c(0.025, 0.975), na.rm=TRUE)

# fill table cells
out[1,'Peak1'] <- paste(peaksmeanTbGHCND95_terr$peaklocs[[1]][1], ' [', paste(qTbGHCND95_terr1, collapse=','), ']', sep='')
out[1,'Peak2'] <- paste(peaksmeanTbGHCND95_terr$peaklocs[[1]][2], ' [', paste(qTbGHCND95_terr2, collapse=','), ']', sep='')
out[2,'Peak1'] <- paste(peaksmeanTbGHCND95_mar$peaklocs[[1]][1], ' [', paste(qTbGHCND95_mar1, collapse=','), ']', sep='')
out[3,'Peak1'] <- paste(peaksmeanTmax_terr$peaklocs[[1]][1], ' [', paste(qTmax_terr1, collapse=','), ']', sep='')
out[3,'Peak2'] <- paste(peaksmeanTmax_terr$peaklocs[[1]][2], ' [', paste(qTmax_terr2, collapse=','), ']', sep='')
out[4,'Peak1'] <- paste(peaksmeanTmax_mar$peaklocs[[1]][1], ' [', paste(qTmax_mar1, collapse=','), ']', sep='')
out[4,'Peak2'] <- paste(peaksmeanTmax_mar$peaklocs[[1]][2], ' [', paste(qTmax_mar2, collapse=','), ']', sep='')
out[4,'Peak3'] <- paste(peaksmeanTmax_mar$peaklocs[[1]][3], ' [', paste(qTmax_mar3, collapse=','), ']', sep='')
out[5,'Peak1'] <- paste(peaksmeanTSM_favorableGHCND95_terr$peaklocs[[1]][1], ' [', paste(qTSM_favorableGHCND95_terr1, collapse=','), ']', sep='')
out[5,'Peak2'] <- paste(peaksmeanTSM_favorableGHCND95_terr$peaklocs[[1]][2], ' [', paste(qTSM_favorableGHCND95_terr2, collapse=','), ']', sep='')
out[6,'Peak1'] <- paste(peaksmeanTSM_favorableGHCND95_mar$peaklocs[[1]][1], ' [', paste(qTSM_favorableGHCND95_mar1, collapse=','), ']', sep='')

# write out
out
write.csv(out, file='tables/peak_locations.csv', row.names=FALSE)

##############################################
## Write out table of GAMM results
## need models from above and model averages
##############################################
out2 <- data.frame(model=character(0), r2=character(0), n=character(0), variable=character(0), smooth=numeric(0), estimate=numeric(0), se=numeric(0), t=numeric(0), p=numeric(0), RVI=numeric(0), edf=numeric(0), F=numeric(0))

modsout <- list(Tmax=modTmax, Tb=modTbGHCND95, TSM=modGHCND95, TSMnoacc=modTSMfav_noacc, TSMaccterm=modTSMfav_accterm, TSMARRbyspp=modGHCND95ARRbyspp, TSM_marBTmore=modGHCND95_marBTmore, TSM_marBTless=modGHCND95_marBTless)
modavgsout <- list(Tmax=modavgTmax, Tb=modavgTbGHCND95, TSM=modavgGHCND95, TSMnoacc=modavgTSMfav_noacc, TSMaccterm=modavgTSMfav_accterm, TSMARRbyspp=modavgGHCND95ARRbyspp, TSM_marBTmore=modavgGHCND95_marBTmore, TSM_marBTless=modavgGHCND95_marBTless)

for(i in 1:length(modsout)){
	#terms <- unlist(strsplit(gsub('.*~', '', as.character(modsout[[i]]$gam$pred.formula)), split=' \\+ '))
	summ <- summary(modsout[[i]]$gam)

	# non-smooth terms
	for(j in 1:nrow(summ$p.table)){
		var <- gsub('\\(|\\)|Terrestrial|LT50|2LT|leth', '', rownames(summ$p.table)[j])
		indxrvi <- grep(var, names(modavgsout[[i]]$importance))
		temp <- data.frame(
			model = names(modsout)[i],
			r2 =if(j==1) round(summ$r.sq,2) else '',
			n = if(j==1) summ$n else '',
			variable = var,
			smooth = 0,
			estimate = round(summ$p.table[j, 'Estimate'],2),
			se = round(summ$p.table[j, 'Std. Error'],2),
			t = round(summ$p.table[j, 't value'],2),
			p = signif(summ$p.table[j, 'Pr(>|t|)'],2),
			RVI = round(ifelse(length(indxrvi)>0, no=NA, yes=modavgsout[[i]]$importance[indxrvi]),2),
			edf = NA,
			F = NA)
		out2 <- rbind(out2, temp)
	}

	# smooth terms
	for(j in 1:nrow(summ$s.table)){
		var <- gsub('s\\(lat\\)\\:Realm', '', rownames(summ$s.table)[j])
		temp <- data.frame(
			model = names(modsout)[i],
			r2='',
			n='',
			variable = paste('Latitude:', var, sep=''),
			smooth = 1,
			estimate = NA,
			se = NA,
			t = NA,
			p = signif(summ$s.table[j, 'p-value'],2),
			RVI = round(ifelse(var=='Marine', no=NA, yes=modavgsout[[i]]$importance['s(lat, by = Realm)']),2),
			edf = round(summ$s.table[j, 'edf'],2),
			F = round(summ$s.table[j, 'F'],2))
		out2 <- rbind(out2, temp)
	}
}

# format p-values
orig <- options(scipen=1)
# rnd <- out2$p < 0.00001
out2$p <- as.character(out2$p)
# out2$p[rnd] <- '< 0.00001'

out2$p

options(scipen=orig)

# write out
out2
write.csv(out2, file='tables/TableS2_gamm_models.csv', row.names=FALSE, na='')


load.csv <- function(csv.file){

  if(!file.exists(csv.file)) {
        stop(" csv file does not exist \n")
  }

  if (file.size(csv.file) == 0)  {
      stop("\n csv.file is empty \n")
  }

  Incon  <-  file(csv.file, "r")
  if(is.null(Incon)) {
      stop("error in csv file name \n")
  }

  context.file <- NULL
  result = tryCatch({
    context.file=read.csv(csv.file)
  },   error = function(e) {
    context.file=NULL
  } )
  if(is.null(context.file)) {
      stop("error in csv file name \n")
  }
  AttributesList <- as.list(names(context.file)[2:length(names(context.file))])
  colnames(context.file) <- NULL
  context.matrix <- as.matrix(context.file)
  ObjectList <- as.list(context.matrix[,1])
  context.matrix<- context.matrix[,-1]

  returned.list <- list("Objects" = ObjectList,
                        "Attributes" = AttributesList,
                        "Matrix" = context.matrix)
  close(Incon)
  return (returned.list)
}

csv.to.rcf <- function(csv.file,output.rcf.file) {
  if(is.null(output.rcf.file)) {
      stop("error in rcf_context_file file   - terminating")
  }
  OutCon <- file(output.rcf.file,"w")

  ctx = load.csv(csv.file)

  ##################################### generating the RCF file

  writeLines("[Relational Context]", OutCon)
  writeLines("Default Name", OutCon)
  writeLines("[Binary Relation]", OutCon)
  writeLines("Name_of_dataset", OutCon)
  writeLines(paste(ctx$Objects, collapse = ' | '),OutCon)
  writeLines(paste(ctx$Attributes, collapse = ' | '),OutCon)
  for(i in 1:length(ctx$Objects)) {
    matching_List <- ctx$Matrix[i,]
    writeLines(paste(matching_List, collapse = ' '), OutCon)
  }
  writeLines("[END Relational Context]", OutCon)
  ##################################### generating the csv file
  close(OutCon)
}


# PROPOSAL TO CALCULATE WINDOW MEAN
# =================================
# =================================

# Idea: Get Data From all words in timespan, calculate, write back

# Steps
#   Connect to DB
#   Get all data from DB
#   Reshape 1: make big table
#   Calculation
#   Plot Example Word "Flugzeug"
#   Reshape II: make tall table (date, w_id, window_value)
#   Write back into DB

#RESHAPE II
#==========
# prepare data for mysql (melt down big table and rename w_ids)
# Goal of three columns: date, w_id, window8
# 15:41
data_for_mysql <- ts[]
data_for_mysql$date <- ts[,c("date_of_wordentry")] # add right dates
# melting porocess
data_for_mysql <- melt(data_for_mysql, "date",1:(length(colnames(data_for_mysql))-1), variable.name="w_id", value.name="window8")
# <2min
# get w_ids as numeric ("w_id_5" => 5)
string_without_w_id <- function(w_id_name) {as.numeric(substr(w_id_name,6, nchar(w_id_name)))}
data_for_mysql$w_id <- string_without_w_id(as.character(data_for_mysql$w_id))


summary.PAFit_data <- function(object,...){
  print(object)
  cat("Type of network:",object$net_type[1],"\n");
  cat("Number of nodes in the final network:",length(object$final_deg),"\n")
  if (object$net_type[1] == "directed") {
      cat("Number of edges in the final network:",sum(object$final_deg),"\n")
  } else {
      cat("Number of edges in the final network:",sum(object$final_deg)/2,"\n")
  }
  cat("Number of new nodes:",length(object$final_deg) - object$initial_nodes,"\n")
  if (object$net_type[1] == "directed") {
    cat("Number of new edges:", sum(object$sum_m_k) + sum(object$offset_m_tk),"\n")
  } else {
      cat("Number of new edges:", sum(object$sum_m_k) + sum(object$offset_m_tk), "\n")
  }
  cat("Number of time-steps:",  object$T,"\n");
  if ("directed" == object$net_type[1]) {
      cat("Maximum in-degree:", object$deg_max,"\n");
  } else {
      cat("Maximum degree:", object$deg_max,"\n");
  }
  cat("Number of bins:", object$g,"\n");
}


#Rienje Veenhof and Frank Fluit
#Project for the course Geoscripting at Wageningen University
#28-1-2021
#This project will investigate what the effects of the COVID lockdown have been
#on the air quality in Nepal and Asia as a whole. For this we use sattelite data
#on NO2 levels and Optical Depth (the ratio between reflected and transmitted light
#by aerosols). The results will be displayed in an interactive shiny app.

#install needed package
if(!"zeallot" %in% rownames(installed.packages())){install.packages("zeallot")}
library(zeallot)

#Create needed directories
dir.create('data', showWarnings = FALSE)
dir.create('leaflet/www', showWarnings = FALSE)

#Source needed functions
source('R/download_raster.r')
source('R/get_adm_areas.r')
source('leaflet/app.R')
source('R/difference_raster.r')
source('R/extract_values.r')

#Download picture that is to be used on the website
urlPicture <- "https://www.dropbox.com/s/ce3x9rrfpaayb8v/COVID-19-proves-that-Kathmandu-can-be-cleaned-up-2-min-1.jpg?dl=1"
download.file(urlPicture, 'leaflet/www/Kathmandu1.jpg')

#Download administrative areas of Nepal and Asia
countries <- c('AFG', 'BGD', 'BTN', 'BRN', 'KHM',
               'CHN', 'HKG', 'IND', 'IDN', 'JPN',
               'KGZ', 'LAO', 'MAC', 'MYS', 'MDV',
               'MNG', 'MMR', 'NPL', 'PRK', 'PAK',
               'PNG', 'PHL', 'SGP', 'KOR', 'LKA',
               'TWN', 'TJK', 'THA', 'TLS', 'TKM',
               'VNM')
nepal_regions <- get_adm_areas('NPL', region = TRUE)
asia <- get_many_adm_areas(countries)

#store urls
#Optical density
#2018
urlOD181 ="https://www.dropbox.com/s/qu5k7dx3hbacpzi/nAerosol_Asia_January_2018.tif?dl=1"
urlOD184 ="https://www.dropbox.com/s/c5j2vjp5lr8shp0/nAerosol_Asia_April_2018%20%281%29.tif?dl=1"
urlOD187 ="https://www.dropbox.com/s/drfjdab6drxqo7s/nAerosol_Asia_July_2018%20%281%29.tif?dl=1"
urlOD1810 ="https://www.dropbox.com/s/o28py1n4lylqb1y/nAerosol_Asia_October_2018.tif?dl=1"

#2019
urlOD191 ="https://www.dropbox.com/s/oeqovmjb1xh3wa0/nAerosol_Asia_January_2019.tif?dl=1"
urlOD194 ="https://www.dropbox.com/s/0rv4hqyhimw27m3/nAerosol_Asia_April_2019.tif?dl=1"
urlOD197 ="https://www.dropbox.com/s/7gg9c6al4t4e6e3/nAerosol_Asia_July_2019.tif?dl=1"
urlOD1910 ="https://www.dropbox.com/s/jp6dpdnyem8kmrk/nAerosol_Asia_October_2019.tif?dl=1"

#2020
urlOD201 ="https://www.dropbox.com/s/pclknmr0lcyjgfr/nAerosol_Asia_January_2020.tif?dl=1"
urlOD204 ="https://www.dropbox.com/s/llxxyfxnvtzz5f9/nAerosol_Asia_April_2020.tif?dl=1"
urlOD207 ="https://www.dropbox.com/s/xt5x8mhug80wt21/nAerosol_Asia_July_2020.tif?dl=1"
urlOD2010 ="https://www.dropbox.com/s/pn1jfhuu6kgcgwx/nAerosol_Asia_October_2020.tif?dl=1"

#No2
#2019
urlN191 ="https://www.dropbox.com/s/hrbfiwfmjn0niw8/mean_NO2_values_Nepal_January_2019.tif?dl=1"
urlN194 ="https://www.dropbox.com/s/ht3wpbljbwso3g3/mean_NO2_values_Nepal_April_2019.tif?dl=1"
urlN197 ="https://www.dropbox.com/s/gy31jixnve7o1mj/mean_NO2_values_Nepal_July_2019.tif?dl=1"
urlN1910 ="https://www.dropbox.com/s/k50ghndd8o70jkp/mean_NO2_values_Nepal_October_2019.tif?dl=1"

#2020
urlN201 ="https://www.dropbox.com/s/ue6u44xcashajt9/mean_NO2_values_Nepal_January_2020.tif?dl=1"
urlN204 ="https://www.dropbox.com/s/e7fsvqlnb11i1j4/mean_NO2_values_Nepal_April_2020.tif?dl=1"
urlN207 ="https://www.dropbox.com/s/1lkjyhsbo06uq2t/mean_NO2_values_Nepal_July_2020.tif?dl=1"
urlN2010 ="https://www.dropbox.com/s/5r59dn2lhuh0ggl/mean_NO2_values_Nepal_October_2020.tif?dl=1"

#Download  rasters
urls <- c(urlOD181, urlOD184, urlOD187, urlOD1810,
          urlOD191, urlOD194, urlOD197, urlOD1910,
          urlOD201, urlOD204, urlOD207, urlOD2010,
          urlN191, urlN194, urlN197, urlN1910,
          urlN201, urlN204, urlN207, urlN2010)
filenames <- c('data/OD181.tif','data/OD184.tif','data/OD187.tif','data/OD1810.tif',
               'data/OD191.tif','data/OD194.tif','data/OD197.tif','data/OD1910.tif',
               'data/OD204.tif','data/OD204.tif','data/OD207.tif','data/OD2010.tif',
               'data/N191.tif','data/N194.tif','data/N197.tif','data/N1910.tif',
               'data/N201.tif','data/N204.tif','data/N207.tif','data/N210.tif')
raster_list <- download_many_raster(urls, filenames)

c(OD181, OD184, OD187, OD1810,
  OD191, OD194, OD197, OD1910,
  OD201, OD204, OD207, OD2010,
  N191, N194, N197, N1910,
  N201, N204, N207, N2010) %<-% raster_list

#Extract mean Nitrogen values for all time periods and bind to spatial polygon
N_nepal <- extract_spatial(N191, nepal_regions)
N_nepal <- extract_df(N194, nepal_regions, N_nepal)
N_nepal <- extract_df(N197, nepal_regions, N_nepal)
N_nepal <- extract_df(N1910, nepal_regions, N_nepal)
N_nepal <- extract_df(N201, nepal_regions, N_nepal)
N_nepal <- extract_df(N204, nepal_regions, N_nepal)
N_nepal <- extract_df(N207, nepal_regions, N_nepal)
N_nepal <- extract_df(N2010, nepal_regions, N_nepal)

#Extract mean Optical depth values for all time periods and bind to spatial polygon
OD_asia <- extract_spatial(OD181, asia)
OD_asia <- extract_df(OD184, asia, OD_asia)
OD_asia <- extract_df(OD187, asia, OD_asia)
OD_asia <- extract_df(OD1810, asia, OD_asia)
OD_asia <- extract_df(OD191, asia, OD_asia)
OD_asia <- extract_df(OD194, asia, OD_asia)
OD_asia <- extract_df(OD197, asia, OD_asia)
OD_asia <- extract_df(OD1910, asia, OD_asia)
OD_asia <- extract_df(OD201, asia, OD_asia)
OD_asia <- extract_df(OD204, asia, OD_asia)
OD_asia <- extract_df(OD207, asia, OD_asia)
OD_asia <- extract_df(OD2010, asia, OD_asia)

#Create difference rasters
#We put this in a function that is kind of arbitrary but we did it because it
#looks neat
#First for optical distance
dif_jan18OD <- dif_func(OD204,OD181)
dif_apr18OD <- dif_func(OD204,OD184)
dif_jul18OD <- dif_func(OD204,OD187)
dif_oct18OD <- dif_func(OD204,OD1810)

dif_jan19OD <- dif_func(OD204,OD191)
dif_apr19OD <- dif_func(OD204,OD194)
dif_jul19OD <- dif_func(OD204,OD197)
dif_oct19OD <- dif_func(OD204,OD1910)

dif_jan20OD <- dif_func(OD204,OD201)
dif_jul20OD <- dif_func(OD204,OD207)
dif_oct20OD <- dif_func(OD204,OD2010)

#Then for Nitrogen values
dif_jan19N <- dif_func(N204,N191)
dif_apr19N <- dif_func(N204,N194)
dif_jul19N <- dif_func(N204,N197)
dif_oct19N <- dif_func(N204,N1910)

dif_jan20N <- dif_func(N204,N201)
dif_jul20N <- dif_func(N204,N207)
dif_oct20N <- dif_func(N204,N2010)

#Prepare the OD_asia sp to a Dataframe containing dates and countries
#as column names to be able to plot them in the app
OD_asias <-as(OD_asia,Class="Spatial")
country_column <-OD_asias@data$NAME
OD_data <-data.frame(OD_asias@data[12:23])
OD <- cbind(country_column,OD_data)
OD <- data.frame(t(OD))
OD <-tail(OD,-1)
names(OD) <- c("Bangladesh",
               "Burma","Brunei_Darussalam","Cambodia","Sri_Lanka","China","Afghanistan","Bhutan","India","Japan","Kyrgyzstan",
               "Korea_Democratic_People_Republic_of","Korea_Republic_of","Lao_People_Democratic_Republic","Mongolia",
               "Maldives","Malaysia","Hong_Kong","Macau","Nepal","Pakistan","Papua_New_Guinea","Philippines","Singapore","Thailand",
               "Tajikistan","Turkmenistan","Vietnam","Indonesia","Timor_Leste","Taiwan")
Date <- c("2018-01-15","2018-04-15","2018-07-15","2018-10-15","2019-01-15","2019-04-15","2019-07-15",
          "2019-10-15","2020-01-15","2020-04-15","2020-07-15","2020-10-15")
Date <- as.Date(Date,"%Y-%m-%d")
OD <- data.frame(OD, Date)

#Run RShiny script
shinyApp(ui = ui, server = server)

#End


#Rscript

#####################################################################################################################
#####################################################################################################################
################################# Calculate community indexes from observation data #################################
#####################################################################################################################
#####################################################################################################################

###################### Packages R

suppressMessages(library(tidyr))

###################### Load arguments and declaring variables

args <- commandArgs(trailingOnly = TRUE)

if (length(args) < 4) {
    stop("At least one argument must be supplied, an input dataset file (.tabular).", call. = FALSE) # if no args -> error and exit1

} else {
    import_data <- args[1] ###### Nom du fichier importé avec son extension / file name imported with the file type ".filetype"
    index <- args[2] ###### List of selected metrics to calculate
    source(args[3]) ###### Import functions
}
#### d_ata must be a dataframe with at least 3 variables : unitobs representing location and year ("observation.unit"), species code ("species.code") and abundance ("number")

#Import des données / Import data
obs <- read.table(import_data, sep = "\t", dec = ".", header = TRUE, encoding = "UTF-8") #
obs[obs == -999] <- NA
factors <- fact_det_f(obs = obs)
obs_type <- def_typeobs_f(obs = obs)
obs <- create_unitobs(data = obs)

vars_data <- c("observation.unit", "species.code", "number")
err_msg_data <- "The input dataset doesn't have the right format. It need to have at least the following 3 variables :\n- observation.unit (or location and year)\n- species.code\n- number\n"
check_file(obs, err_msg_data, vars_data, 3)

####################################################################################################
################# create community metrics table ## Function : calc_biodiv_f #######################
####################################################################################################

########################################################################################################################
calc_biodiv_f <- function(d_ata, unitobs = "observation.unit", code_species = "species.code", nombres = "number",
                         indices = index) {
    ## Purpose: compute biodiversity indexes
    ## ----------------------------------------------------------------------
    ## Arguments: d_ata : input observation file
    ##            unitobs : name of column observation unit
    ##            code_species : name of species column
    ##            nombres : name of abundance column
    ##            indices : list of indexes to compute
    ## ----------------------------------------------------------------------
    ## Author: Yves Reecht, Date: 29 oct. 2010, 08:58 modified by Coline ROYAUX in june 2020

    ## Supress lines that doesn't represent a species :

    notspline <- grep("(sp\\.)$|([1-9])$|^(Absencemacrofaune)$|^(NoID)$|^(Acrobranc)$|^(Acrodigit)$|^(Acroencr)$|^(Acrosubm)$|^(Acrotabu)$|^(Adredure)$|^(Adremoll)$|^(Algaturf)$|^(Balimona)$|^(Corablan)$|^(CoradurV)$|^(Coraenal)$|^(Coramor1)$|^(Coramor2)$|^(Coramou)$|^( Dallcora)$|^(Debrcora)$|^(Debris)$|^(Hare)$|^(HexaChar)$|^(MuraCong)$|^(Nacrbran)$|^(Nacrcham)$|^(Nacrencr)$|^(Nacrfoli)$|^(Nacrmass)$|^(Nacrsubm)$|^(Recrcora)$|^(Roche)$|^(Sable)$|^(Vase)$", d_ata[, code_species], value = FALSE)
    if (length(notspline) != 0) {
        d_ata <- d_ata[-notspline, ]
    }

    ## Suppress unused factor levels :
    d_ata <- .GlobalEnv$drop_levels_f(df = d_ata)

    ## aggregation of data if not already done :
    if (nrow(d_ata) > nrow(expand.grid(unique(d_ata[, unitobs]), unique(d_ata[, code_species])))) {
        d_ata <- agregations_generic_f(d_ata = d_ata, metrics = nombres,
                                      factors = c(unitobs, code_species),
                                      list_fact = NULL)
    }

    df_biodiv <- as.data.frame(as.table(tapply(d_ata[, nombres],
                                               d_ata[, unitobs],
                                               sum, na.rm = TRUE)))

    colnames(df_biodiv) <- c(unitobs, nombres)

## ##################################################
    ## species richness :
    d_ata$presence_absence <- .GlobalEnv$pres_abs_f(nombres = d_ata[, nombres], logical = FALSE)

    df_biodiv$species_richness <- as.vector(tapply(d_ata$presence_absence,
                                                   d_ata[, unitobs], sum, na.rm = TRUE),
                                            "integer")
    ## ... as.vector to avoid the class "array".

 ## ##################################################
    ## Simpson, Shannon indexes and derivatives :

    mat_nb <- tapply(d_ata[, nombres], # Matrix of individual count /species/unitobs.
                         list(d_ata[, unitobs], d_ata[, code_species]),
                         sum, na.rm = TRUE)

    mat_nb[is.na(mat_nb)] <- 0  # Vrais zéros

    ## each species individual proportion in the dataset :
    prop_indiv <- sweep(mat_nb, 1,
                       apply(mat_nb, 1, sum, na.rm = TRUE), # individual count / unitobs ; equiv df_biodiv$nombre.
                       FUN = "/")

    ## Simpson indexes :
    df_biodiv$simpson <- apply(prop_indiv^2, 1, sum, na.rm = TRUE)

    if (any(is.element(c("all", "simpson.l"), indices))) {
        df_biodiv$simpson_l <- 1 - df_biodiv$simpson
    }

    ## Shannon index :
    df_biodiv$shannon <- -1 * apply(prop_indiv * log(prop_indiv), 1, sum, na.rm = TRUE)

    ## Pielou index :
    if (any(is.element(c("all", "pielou"), indices))) {
        df_biodiv$pielou <- df_biodiv$shannon / log(df_biodiv$species_richness)
    }

    ## Hill index :
    if (any(is.element(c("all", "hill"), indices))) {
        df_biodiv$hill <- (1 - df_biodiv$simpson) / exp(df_biodiv$shannon) # equiv df_biodiv$l.simpson / exp(df_biodiv$shannon)
    }

    return(df_biodiv)
}

################# Analysis

res <- calc_numbers_f(obs, obs_type = obs_type, factors = factors, nb_name = "number")

table_comm_indexes <- calc_biodiv_f(res, unitobs = "observation.unit", code_species = "species.code", nombres = "number",
                         indices = index)
table_comm_indexes <- create_year_location(table_comm_indexes)
#Save dataframe in a tabular format

filename_comm <- "TabCommunityIndexes.tabular"
write.table(table_comm_indexes, filename_comm, row.names = FALSE, quote = FALSE, sep = "\t", dec = ".", fileEncoding = "UTF-8")
cat(paste("\nWrite table with Community indexes. \n--> \"", filename_comm, "\"\n", sep = ""))


library(gsubfn)

#' Compute date range used for modelling from specification.
#'
#' Requires specifying at least two of (\code{first_day_modelled},
#' \code{weeks_modelled}, and one of (\code{last_day_modelled}, \code{days_ignored})).
#'
#' @param alldates List of dates for which data is available.
#' @param first_day_modelled First day modelled (defaults to NULL)
#' @param last_day_modelled Last day modelled (defaults to NULL)
#' @param days_ignored Days ignored (defaults to 7)
#' @param weeks_modelled Weeks modelled (defaults to NULL)
#' @param days_per_step Days per step (defaults to 7)
#' @return Named list consisting of (Nstep, Tstep, Tcond, Tcur, Tignore)
process_dates_modelled = function(
  alldates,
  first_day_modelled = NULL,
  last_day_modelled = NULL,
  days_ignored = 7,
  weeks_modelled = NULL,
  days_per_step = 7
) {
  list_args = paste(
    ", first_day_modelled=", first_day_modelled,
    ", weeks_modelled=", weeks_modelled,
    ", last_day_modelled=", last_day_modelled,
    ", days_ignored=", days_ignored,
    ", days_per_step=", days_per_step,
    sep=""
  )
  Tall = length(alldates)
  first_day_of_data = alldates[1]
  last_day_of_data = alldates[Tall]
  print(paste("last_day_of_data",last_day_of_data))
  if (!is.null(last_day_modelled)) {
    last_day_modelled = as.Date(last_day_modelled)
    if (!is.null(days_ignored) &&
        as.double(last_day_of_data-last_day_modelled)<days_ignored) {
      stop(paste(
        "Last day modelled is less than ", days_ignored,
        " before last day of data", list_args,
        sep=""
      ))
    }
  } else if (!is.null(days_ignored)) {
    last_day_modelled = last_day_of_data - days_ignored
    print(paste("last_day_modelled",last_day_modelled))
  } else {
    last_day_modelled = NULL
  }

  if (!is.null(first_day_modelled)) {
    first_day_modelled = as.Date(first_day_modelled)
    if (is.null(last_day_modelled)) {
      if (is.null(weeks_modelled)) {
        stop(paste("Cannot work out last day modelled", list_args, sep=""))
      } else {
        last_day_modelled = first_day_modelled + 7*opt$weeks_modelled - 1
      }
    } else {
      weeks = floor((last_day_modelled-first_day_modelled+1)/7)
      if (!is.null(weeks_modelled) && weeks != weeks_modelled) {
        stop(paste("First/last day modelled and weeks modelled inconsistent", list_args, sep=""))
      }
      first_day_modelled = last_day_modelled - 7*weeks + 1
      #print(paste("first_day_modelled",first_day_modelled))
    }
  } else if (!is.null(last_day_modelled) && !is.null(opt$weeks_modelled)) {
    first_day_modelled = last_day_modelled - 7*opt$weeks_modelled + 1
    #print(paste("first_day_modelled",first_day_modelled))
    if (first_day_modelled < first_day_of_data) {
      stop(paste(
          "First day modelled is before first data of data", list_args,
          sep=""
      ))
    }
  } else {
    stop(paste(
      "Cannot work out first day modelled", list_args,
      sep=""
    ))
  }
  days_modelled = as.double(last_day_modelled-first_day_modelled)+1
  Tstep <- days_per_step
  #Tlik = floor(days_modelled/Tstep)*Tstep
  Tlik = floor(days_modelled/7)*7 # model in units of weeks
  if (Tlik <= 0) {
    stop(paste(
      "Number of days modelled is <= 0", list_args,
      sep=""
    ))
  }
  Nstep = Tlik / Tstep
  Tcond = sum(alldates<first_day_modelled)
  stopifnot(first_day_modelled==alldates[Tcond+1])
  Tcur = Tcond + Tlik
  Tignore = Tall - Tcur
  message(paste("Tstep =",Tstep))
  message(paste("Nstep =",Nstep))
  message(paste("Days modelled =",Tlik))
  message(paste("Days ignored =",Tignore))
  message(paste("First day modelled =",alldates[Tcond+1]))
  message(paste("Last day modelled =",alldates[Tcur]))

  return(list(
    Nstep = Nstep,
    Tstep = Tstep,
    Tcond = Tcond,
    Tlik = Tlik,
    Tcur = Tcur,
    Tignore = Tignore
  ))

}

time_distances = function(
    time_steps,
    Tstep,
    days,
    lockdown_day=as.Date("2020-03-23")
) {
    # time steps
    times = 1:(time_steps)
    timedist = matrix(0, time_steps, time_steps)
    for (i in 1:(time_steps)) {
      for (j in 1:(time_steps)) {
        timedist[i, j] = abs(times[i] - times[j]) * Tstep
      }
    }

    # precompute lockdown cutoff kernel
    lockdown_day = as.Date("2020-03-23")
    days_period_start = days[seq(1, length(days), Tstep)]
    days_period_start = vapply(days_period_start, (function (day) as.Date(day, format="%Y-%m-%d")), double(1))
    day_pre_lockdown = vapply(days_period_start, (function (day) day < lockdown_day), logical(1))

    time_corellation_cutoff = matrix(0,time_steps,time_steps)
    for (i in 1:(time_steps)) {
      for (j in 1:(time_steps)) {
        time_corellation_cutoff[i, j] = !xor(day_pre_lockdown[i], day_pre_lockdown[j])
      }
    }

    list(
        time_distances = timedist,
        time_correlations = time_corellation_cutoff
    )
}


tissue='Brain_Frontal_Cortex_BA9'
#tissue='Whole_Blood'

st<-read.table(paste0('~/../Dropbox/DansPaper/data/replication/st_',tissue,'.txt'),header = T,stringsAsFactors = F)
st<-st[,-4]
colnames(st)<-c('geneid','r_st','p_st')
length(intersect(which((st$p_st)<0.05),which(st$r_st>0.1)))
length(intersect(which(p.adjust(st$p_st,method = 'BH')<0.05),which(st$r_st>0.1)))

ut<-read.table(paste0('~/../Dropbox/DansPaper/data/replication/ut_modified_',tissue,'.txt'),header = T,stringsAsFactors = F)
ut<-ut[,-4]
colnames(ut)<-c('geneid','r_ut','p_ut')
length(intersect(which((ut$p_ut)<0.05),which(ut$r_ut>0.1)))
length(intersect(which(p.adjust(ut$p_ut,method = 'BH')<0.05),which(ut$r_ut>0.1)))

xt<-read.table(paste0('~/../Dropbox/DansPaper/data/replication/xt_',tissue,'.txt'),header = T,stringsAsFactors = F)
xt<-xt[,-4]
colnames(xt)<-c('geneid','r_xt','p_xt')
length(intersect(which((xt$p_xt)<0.05),which(xt$r_xt>0.1)))
length(intersect(which(p.adjust(xt$p_xt,method = 'BH')<0.05),which(xt$r_xt>0.1)))

df<-merge(ut,xt,by=1,all=T)
df<-merge(df,st,by=1,all=T)

df[is.na(df[,2]),2]<-0
df[is.na(df[,3]),3]<-1
df[is.na(df[,4]),4]<-0
df[is.na(df[,5]),5]<-1
df[is.na(df[,6]),6]<-0
df[is.na(df[,7]),7]<-1
df[,'r_st']<-ifelse(df[,'r_st']<0,0,df[,'r_st'])
df[,'r_ut']<-ifelse(df[,'r_ut']<0,0,df[,'r_ut'])
df[,'r_xt']<-ifelse(df[,'r_xt']<0,0,df[,'r_xt'])

df$r2_st<-df$r_st^2
df$r2_xt<-df$r_xt^2
df$r2_ut<-df$r_ut^2

df$iG_r_ut<-ifelse((df$r_ut>0.1 & df$p_ut<0.05),1,0)
df$iG_r_xt<-ifelse((df$r_xt>0.1 & df$p_xt<0.05),1,0)
df$iG_r_st<-ifelse((df$r_st>0.1 & df$p_st<0.05),1,0)

df$iG_r2_ut<-ifelse((df$r2_ut>0.01 & df$p_ut<0.05),1,0)
df$iG_r2_xt<-ifelse((df$r2_xt>0.01 & df$p_xt<0.05),1,0)
df$iG_r2_st<-ifelse((df$r2_st>0.01 & df$p_st<0.05),1,0)

sum(df$iG_r_ut)
sum(df$iG_r_xt)
sum(df$iG_r_st)

sum(df$iG_r2_ut)
sum(df$iG_r2_xt)
sum(df$iG_r2_st)

ut_fun<-function(a,b){  #a=st
  if (a==0 & b==0){
    col='grey'
  }else if(a==1 & b==1){
    col='black'
  }else if(a==1 & b==0){
    col=brewer.pal(12, "Paired")[8] #'firebrick2'
  }else if(a==0 & b==1){
    col=brewer.pal(12, "Paired")[2] #'dodgerblue3'
  }
  return(col)
}

xt_fun<-function(a,b){  #a=st
  if (a==0 & b==0){
    col='grey'
  }else if(a==1 & b==1){
    col='black'
  }else if(a==1 & b==0){
    col=brewer.pal(12, "Paired")[8]
  }else if(a==0 & b==1){
    col=brewer.pal(12, "Paired")[4]
  }
}

iG_r_st<- df[df$iG_r_st==1,1]
iG_r_ut<- df[df$iG_r_ut==1,1]
iG_r_xt<- df[df$iG_r_xt==1,1]

iG_r2_st<- df[df$iG_r2_st==1,1]
iG_r2_ut<- df[df$iG_r2_ut==1,1]
iG_r2_xt<- df[df$iG_r2_xt==1,1]

#plot
library (VennDiagram)
library(RColorBrewer)
library("vioplot")

png(paste0('~/../Dropbox/DansPaper/figures/tmp/rep_',tissue,'.png'),width = 2400,height = 600,res=330)
par(mfcol=c(1,4))

#barplot
par(mai=c(1,1,0.5,0.5))
par(mgp=c(3,0.8,0))
par(mar=c(5,5,1,0))
barplot(c(sum(df$iG_r_st),sum(df$iG_r_ut),sum(df$iG_r_xt)),
        ylab="Number of iGenes",
        ylim = c(0,max(c(sum(df$iG_r_st),sum(df$iG_r_ut),sum(df$iG_r_xt)+800))),
        beside=F,horiz = F,las=2,cex.axis=1,
        col = brewer.pal(12, "Paired")[c(8,2,4)],
        names.arg=c("PrediXcan","UTMOST","XT-SCAN")
)

#venn plot
mgp=c(0,0,0)
plot(c(1),c(1),type="n",xaxt="n",yaxt="n",xlab = '',ylab = '',bty='n')
#venn(x= list('PrediXcan' = iG_r_st,'UTMOST' = iG_r_ut,'XT-SCAN' = iG_r_xt), col="transparent",fill=brewer.pal(12, "Paired")[c(7,1,3)], lwd=0.6, cex=1.5, cat.cex=0.8)

#scatter plot
df$col_ut<-mapply(ut_fun,df$iG_r_st,df$iG_r_ut)
df$col_xt<-mapply(xt_fun,df$iG_r_st,df$iG_r_xt)

#ut v.s. st
par(mar=c(2.5,2.5,1,1),mgp=c(1.5,0.5,0))

plot(-1,-1,xlab = 'PrediXcan',ylab='UTMOST',bty='l',xlim = c(0,1),ylim = c(0,1))
points(df$r_st,df$r_ut,col=df$col_ut,pch=20,cex=0.5)
segments(-1,-1,1,1,col = 'red',lty=2)

#xt v.s. st

plot(-1,-1,xlab = 'PrediXcan',ylab='XT-SCAN',bty='l',xlim = c(0,1),ylim = c(0,1))
points(df$r_st,df$r_xt,col=df$col_xt,pch=20,cex=0.5)
segments(-1,-1,1,1,col = 'red',lty=2)

dev.off()

venn.diagram(x= list('PrediXcan' = iG_r_st,'UTMOST' = iG_r_ut,'XT-SCAN' = iG_r_xt), filename = paste0('~/../Dropbox/DansPaper/figures/tmp/rep_',tissue,'_venn.png'), height = 800, width = 800,,resolution =250, imagetype="png", col="transparent",fill=brewer.pal(12, "Paired")[c(7,1,3)], lwd=0.6, cex=1.5, cat.cex=0.8)

#vio plot

png(paste0('~/../Dropbox/DansPaper/figures/tmp/rep_vio_',tissue,'.png'),width = 500,height = 800,res=150)
vioplot(df$r_st,df$r_ut,df$r_xt,names = c('PrediXcan','UTMOST','XT-SCAN'),col = brewer.pal(12, "Paired")[c(8,2,4)],cex.axis = 1,las=2,ylim=c(0,1),ylab='Pred and Obs correlation r',bty='l',main=tissue)
dev.off()


#' sd_to_precision()
#'only converts numeric columns.
#'
#' @param x_sd table of standard deviation values.
#'
#' @return return a matrix or dataframe of precision values.
#' @export
#'
#' @examples
sd_to_precision <- function(x_sd){
  to_flip <- list()
  for(i in 1:ncol(x_sd)){
    to_flip[[i]] <- is.numeric(x_sd[,i])
  }
  to_flip <- unlist(to_flip)
  z_sd <- data.frame(x_sd[,to_flip])
  for(i in 1:ncol(z_sd)){
      z_sd[,i] <- 1/(z_sd[,i]^2)
  }
  #x_sd[,to_flip] <- z_sd
  for(i in 1:ncol(x_sd)){
    if(to_flip[i] == T){
      x_sd[,i] <- z_sd[,i]
    }
  }
  x_sd <- as.matrix(x_sd) #JAGS likes things served as matrices.
  return(x_sd)
}


## Run matrixQTL to perform whole genome scan for DNA methylation quantitative trait loci.
## Analysis is performed by analysising all genetic variants on each chromosome in turn against all DNA methylation sites.

library(MatrixEQTL)

setwd("")
base.dir = find.package("MatrixEQTL")
useModel = modelLINEAR;

covariates_file_name = "MatrixEQTL/Covariates_Sex_5PCs.txt";
expression_file_name = "MatrixEQTL/Methylation.txt"

## threshold of results to save
pvOutputThreshold = 1e-8;
errorCovariance = numeric();

##load covariate data
cvrt = SlicedData$new();
cvrt$fileDelimiter = "\t";      # the TAB character
cvrt$fileOmitCharacters = "NA"; # denote missing values;
cvrt$fileSkipRows = 1;          # one row of column labels
cvrt$fileSkipColumns = 1;       # one column of row labels
cvrt$fileSliceSize = 2000;      # read file in pieces of 2,000 rows
cvrt$LoadFile(covariates_file_name);

## load methylation data
gene = SlicedData$new();
gene$fileDelimiter = "\t";      # the TAB character
gene$fileOmitCharacters = "NA"; # denote missing values;
gene$fileSkipRows = 1;          # one row of column labels
gene$fileSkipColumns = 1;       # one column of row labels
gene$fileSliceSize = 2000;      # read file in pieces of 2,000 rows
gene$LoadFile( expression_file_name);

for(chr in 1:22){
	SNP_file_name = paste("MatrixEQTL/Genotypes_MinGenoCount5_Chr", chr, ".txt", sep = "")
	output_file_name = paste("MatrixEQTL/Output/Minerva_mQTL_chr", chr, ".txt", sep = "")

	 ## load SNP data
	snps = SlicedData$new();
	snps$fileDelimiter = "\t";      # the TAB character
	snps$fileOmitCharacters = "NA"; # denote missing values;
	snps$fileSkipRows = 1;          # one row of column labels
	snps$fileSkipColumns = 1;       # one column of row labels
	snps$fileSliceSize = 2000;      # read file in pieces of 2,000 rows
	snps$LoadFile( SNP_file_name );

	### run eqtls
	me = Matrix_eQTL_main(
		snps = snps,
		gene = gene,
		cvrt = cvrt,
		output_file_name = output_file_name,
		pvOutputThreshold = pvOutputThreshold,
		useModel = useModel,
		errorCovariance = errorCovariance,
		verbose = TRUE,
		pvalue.hist = "qqplot",
		min.pv.by.genesnp = FALSE,
		noFDRsaveMemory = FALSE)

}


################################################
## STEP 2. Mitochondrial content filter
#################################################
# This is a simplest filter that looks at a threshold value for the mitochondrial content.
# To separate cells with low MT-content from the ones that have a high MT-content what makes us think that are dead.
# This can be a useful first guess. The settings for such a filter can also contain a simple "probabilityThreshold" setting.

# The most uses values in MT-content are between [0.1, 0.2]. There are not too much literature about how to compute
# a threshold. For now, we will offer two methods:
# --> Absolute threshold: In order to be not too extrictive the threshold is set to 0.1
generate_default_values_mitochondrialContent <- function(scdata, config) {

   if (config$filterSettings$method == "absolute_threshold")
        # HARDCODE
        threshold <- 0.1

    return(threshold)
}

#' @description Filters seurat object based on mitochondrialContent
#' @param config list containing the following information
#'          - enable: true/false. Refering to apply or not the filter.
#'          - auto: true/false. 'True' indicates that the filter setting need to be changed depending on some sensible value (it requires
#'          to call generate_default_values_mitochondrialContent)
#'          - filterSettings: slot with thresholds
#'                  - method: String. Method to be used {absolute_threshold}
#'                  - methodSettings: List with the method as key and contain all the filterSettings for this specific method.
#'                          * absolute_threshold: based on a cut-off threshold
#'                                  - maxFraction: Float. maximun pct MT-content that we considere for a alive cell
#'                                  - binStep: Float. Bin size for the histogram
#'                          * we are supposed to add more methods ....
#' @export return a list with the filtered seurat object by mitochondrial content, the config and the plot values

mitochondrialContent <- function(scdata, config){

    # Check if the experiment has MT-content
    if (!"fraction.mt"%in%colnames(scdata@meta.data)){
        message("Warning! No MT-content has been computed for this experiment!")
        return(scdata)
    }

    maxFraction <- config$filterSettings$methodSettings[[config$filterSettings$method]]$maxFraction

    # Check if it is required to compute sensible values. From the function 'generate_default_values_doubletScores', it is expected
    # to get a list with only one element --> maxFraction.
    if (as.logical(toupper(config$auto)))
        maxFraction <- generate_default_values_mitochondrialContent(scdata, config)

    # Check wheter the filter is set to true or false
    if (as.logical(toupper(config$enabled)))
        # Information regarding MT-content is pre-computed during the 'data-ingest'.
        scdata.filtered <- subset(scdata, subset = fraction.mt <= maxFraction)
    else
        scdata.filtered <- scdata

    # update config
    config$filterSettings$methodSettings[[config$filterSettings$method]]$maxFraction <- maxFraction

    # the result object will have to conform to this format: {data, config, plotData : {plot1, plot2}}
    result <- list(
        data = scdata.filtered, # scdata filter
        config = config,
        plotData = list(
            # plot 1: histgram of MT-content
            # AAACCCAAGCGCCCAT-1 AAACCCAAGGTTCCGC-1 AAACCCACAGAGTTGG-1
            #              0.161              0.198              0.284  ...
            mitochondrialFractionHistogram = scdata$fraction.mt,
            # plot 2: There are two alternavitive:
            #           - Scatter plot with UMIs in the x-axis and MT-content in the y-axis
            #           --> code: plot2 = list(u=scdata$nCount_RNA.mt, "MT-content" = scdata$fraction.mt)
            #           - Barplot representing in the x-axis the log10(UMIs) and in the y-axis the MT-content. This option is the one
            #           that is shown in the mockup.
            #           --> code: plot2 = list(log_10_UMIs=log10(scdata$nCount_RNA), MT_content =mscdata$fraction.mt)
            # We have decided to use the scatter plot, but I temporaly leave the other option in the comments.
            # Q: Should we return from the R side the cells that are going to be removed? For this plot it is interesting to color the
            # cells that are going to be excluded.
            mitochondrialFractionLogHistogram = list(u=scdata$nCount_RNA, "MT-content" = scdata$fraction.mt)
        )
    )

    return(result)
}


# Validation plots of functional group forecasts to NEON core/plot/sites,
# plotted by group, each with c/p/s.

rm(list=ls())
source('paths.r')
source('NEFI_functions/crib_fun.r')
library(data.table)

# load forecast
all_fcasts <- readRDS(NEON_cps_fcast_ddirch_16S.path)
# load prior model results
all_fits <- readRDS(prior_delgado_ddirch_16S.path)

# read in obs table that links deprecatedVialID and geneticSampleID
#map <- readRDS(obs.table_16S.path)
map <- readRDS(core_obs_data.path)

# read in prior fit.
#all_fits <- readRDS("/fs/data3/caverill/NEFI_data/16S/scc_gen/JAGS_output/bahram_16S.prior_phylo_new_test.rds")

#validate against observed data by plotting.----

#i = 2

#pdf(NEON_cps.fcast_phyla_16S.path)

#pdf("/fs/data3/caverill/NEFI_data/16S/pecan_gen/figures/NEON_cps.fcast_phylum_16S_new_pH.pdf")
#pdf("/fs/data3/caverill/NEFI_data/16S/pecan_gen/figures/NEON_cps.fcast_phylum_16S_moreC.pdf")
#filename <- "/fs/data3/caverill/NEFI_data/16S/pecan_gen/figures/NEON_cps.fcast_all.groups_16S.pdf"
#filename <- "/fs/data3/caverill/NEFI_data/16S/pecan_gen/figures/NEON_talk.fig_2phyla.pdf"
filename <- "/fs/data3/caverill/NEFI_data/16S/pecan_gen/figures/NEON_organic_phyla_fcast.pdf"
pdf(filename,onefile=T)

#global plot settings.----
par(mfrow = c(3,3))
par(mar = c(2,2,2,2))
par(oma = c(0,0,2,0))
trans <- 0.3
limy <- c(0,1)
core.cex <- 0.7
plot.cex <- 1.0
site.cex <- 1.5
outer.cex <- 2
glob.pch <- 16

for (p in 1:length(all_fcasts)) {
#  for (p in 6:17) {
    #p <- 1
  output <- all_fcasts[[p]]
  fit <- all_fits[[p]]

  # read in observed values
  raw.truth <- readRDS(NEON_phylo_fg_plot.site_obs_16S.path)
  raw.truth <- raw.truth[[p]]

  for (i in 1:ncol(fit$observed)){
  #  for (i in c(6,8)){

    #core.level.----
    # read in core-level forecast
    fcast <- output$core.fit
    # read in core-level observed values
    truth <- raw.truth$core.fit
    #organize data.
    y.fix <- as.data.frame(truth)
    y.fix$deprecatedVialID <- rownames(y.fix)
    y.fix <- merge(y.fix, map[,c("deprecatedVialID", "geneticSampleID")], by = "deprecatedVialID")
    y.fix <- y.fix[!duplicated(y.fix$geneticSampleID),]
    rownames(y.fix) <- gsub('-GEN','',y.fix$geneticSampleID )
    y.fix$geneticSampleID <- NULL
    truth <- y.fix

    for(k in 1:length(fcast)){
      fcast[[k]] <- fcast[[k]][rownames(fcast[[k]]) %in% rownames(truth),]
    }
    #truth <- as.matrix(truth)
    mu <- data.frame(fcast$mean[,i][order(fcast$mean[,i]),drop=FALSE])
    # get prior rsq.]
    ci_0.975 <- fcast$ci_0.975[,i][order(match(names(fcast$ci_0.975[,i]),names(mu))),drop=FALSE]
    # get prior rsq.]
    ci_0.025 <- fcast$ci_0.025[,i][order(match(names(fcast$ci_0.025[,i]),names(mu))),drop=FALSE]
    # get prior rsq.]
    pi_0.975 <- fcast$pi_0.975[,i][order(match(names(fcast$pi_0.975[,i]),names(mu))),drop=FALSE]
    # get prior rsq.]
    pi_0.025 <- fcast$pi_0.025[,i][order(match(names(fcast$pi_0.025[,i]),names(mu))),drop=FALSE]

    colnames(mu) <- colnames(fcast$mean)[i]

    # get prior rsq.]
    group_name <- colnames(fcast$mean)[i]
    if (!group_name %in% colnames(truth) | group_name=="other") next()
    obs.mu   <- truth[,c(group_name),drop=FALSE][order(match(names(truth[,c(group_name),drop=FALSE]),names(mu)))]
    obs.mu <- obs.mu[,c(group_name),drop=FALSE]
    # get prior rsq.
    prior_rsq <- summary(lm(fit$observed[,i] ~ fit$predicted[,i]))$r.squared
    #mod <- betareg::betareg(crib_fun(fit$observed[,i]/rowSums(fit$observed)) ~ crib_fun(fit$predicted[,i]))
    #prior_rsq <-round(summary(mod)$pseudo.r.squared, 2)

    # create plot
    # get ylim (used for plot/site level as well)
    obs_limit <- max(obs.mu, na.rm = T)
    if(max(pi_0.975) > as.numeric(obs_limit)){obs_limit <- max(pi_0.975)}
    limy <- as.numeric(obs_limit)*1.05
    if(limy > 0.95){limy <- 1}

    plot(obs.mu[,i] ~ mu[,i], cex = 0.7, ylim=c(0,limy), main = paste0('core-level ', group_name))

    #r square best fit.
    fit.stats <- lm(obs.mu ~ mu)
    rsq <- round(summary(fit.stats)$r.squared,2)
    #r square 1:1.
    rss <- sum((mu[,i] -      obs.mu[,i])  ^ 2)  ## residual sum of squares
    tss <- sum((obs.mu[,i] - mean(obs.mu[,i])) ^ 2)  ## total sum of squares
    rsq1 <- 1 - rss/tss
    if(rsq1 < 0){rsq1 <- 0}
    #RMSE.
    rmse <- round(sqrt(mean(fit.stats$residuals^2)), 3)
    mtext(paste0('R2=',rsq, " RMSE=",rmse), cex = .7, side = 3, line = -2.7, adj = 0.03)

    #1-to-1 line.
    abline(0,1,lwd=2)
    # best-fit line.
    abline(lm(obs.mu ~mu), lty = 2, col = 'purple')
    #add confidence interval.
    range <- mu[,i]
    polygon(c(range, rev(range)),c(pi_0.975, rev(pi_0.025)), col=adjustcolor('green', trans), lty=0)
    polygon(c(range, rev(range)),c(ci_0.975, rev(ci_0.025)), col=adjustcolor('blue' , trans), lty=0)
    #fraction within 95% predictive interval.
    in_it <- round(sum(as.numeric(obs.mu) < pi_0.975 & as.numeric(obs.mu) > pi_0.025, na.rm = TRUE) / length(obs.mu),2) * 100
    state <- paste0(in_it,'% of obs. within interval.')
    mtext(state,side = 3, cex = 0.7, line = -1.3, adj = 0.05)

    # plot.level----
    # read in plot-level forecast
    fcast <- output$plot.fit
    # read in plot-level observed values
    truth <- raw.truth$plot.fit

    for(k in 1:length(truth)){
      rownames(truth[[k]]) <- gsub('.','_',rownames(truth[[k]]), fixed = T)
      truth[[k]] <- truth[[k]][rownames(truth[[k]]) %in% rownames(fcast$mean),]
    }
    for(k in 1:length(fcast)){
      fcast[[k]] <- fcast[[k]][rownames(fcast[[k]]) %in% rownames(truth$mean),]
    }
    mu <- fcast$mean[,i][order(fcast$mean[,i])]
    ci_0.975 <- fcast$ci_0.975[,i][order(match(names(fcast$ci_0.975[,i]),names(mu)))]
    ci_0.025 <- fcast$ci_0.025[,i][order(match(names(fcast$ci_0.025[,i]),names(mu)))]
    pi_0.975 <- fcast$pi_0.975[,i][order(match(names(fcast$pi_0.975[,i]),names(mu)))]
    pi_0.025 <- fcast$pi_0.025[,i][order(match(names(fcast$pi_0.025[,i]),names(mu)))]
    group_name <- colnames(fcast$mean)[i]
    obs.mu   <- truth$mean[,group_name][order(match(names(truth$mean[,group_name]),names(mu)))]
    obs.lo95 <- truth$lo95[,group_name][order(match(names(truth$lo95[,group_name]),names(mu)))]
    obs.hi95 <- truth$hi95[,group_name][order(match(names(truth$hi95[,group_name]),names(mu)))]

    # create plot

    plot(obs.mu ~ mu, cex = 0.7, ylim=c(0,limy), main = paste0('plot-level ', group_name))
    arrows(c(mu), obs.lo95, c(mu), obs.hi95, length=0.05, angle=90, code=3)

    #r square best fit.
    fit.stats <- lm(obs.mu ~ mu)
    rsq <- round(summary(fit.stats)$r.squared,2)
    #r square 1:1.
    rss <- sum((mu -      obs.mu)  ^ 2)  ## residual sum of squares
    tss <- sum((obs.mu - mean(obs.mu)) ^ 2)  ## total sum of squares
    rsq1 <- 1 - rss/tss
    if(rsq1 < 0){rsq1 <- 0}
    #RMSE.
    rmse <- round(sqrt(mean(fit.stats$residuals^2)), 3)
    mtext(paste0('R2=',rsq, " RMSE=",rmse), cex = .7, side = 3, line = -2.7, adj = 0.03)
    #1:1 line
    abline(0,1, lwd = 2)
    # best-fit line.
    abline(lm(obs.mu ~mu), lty = 2, col = 'purple')
    #add confidence interval.
    range <- mu
    polygon(c(range, rev(range)),c(pi_0.975, rev(pi_0.025)), col=adjustcolor('green', trans), lty=0)
    polygon(c(range, rev(range)),c(ci_0.975, rev(ci_0.025)), col=adjustcolor('blue' , trans), lty=0)
    #fraction within 95% predictive interval.
    in_it <- round(sum(obs.mu < pi_0.975 & obs.mu > pi_0.025) / length(obs.mu),2) *100
    state <- paste0(in_it,'% of obs. within interval.')
    mtext(state,side = 3, cex = .7, line = -1.3, adj = 0.05)

    #site.level----

    #read in site-level forecast
    fcast <- output$site.fit
    # read in site-level observed values
    truth <- raw.truth$site.fit
    #organize data.
    for(k in 1:length(truth)){
      rownames(truth[[k]]) <- gsub('.','_',rownames(truth[[k]]), fixed = T)
      truth[[k]] <- truth[[k]][rownames(truth[[k]]) %in% rownames(fcast$mean),]
    }
    for(k in 1:length(fcast)){
      fcast[[k]] <- fcast[[k]][rownames(fcast[[k]]) %in% rownames(truth$mean),]
    }

    mu <- fcast$mean[,i][order(fcast$mean[,i])]
    ci_0.975 <- fcast$ci_0.975[,i][order(match(names(fcast$ci_0.975[,i]),names(mu)))]
    ci_0.025 <- fcast$ci_0.025[,i][order(match(names(fcast$ci_0.025[,i]),names(mu)))]
    pi_0.975 <- fcast$pi_0.975[,i][order(match(names(fcast$pi_0.975[,i]),names(mu)))]
    pi_0.025 <- fcast$pi_0.025[,i][order(match(names(fcast$pi_0.025[,i]),names(mu)))]
    group_name <- colnames(fcast$mean)[i]
    obs.mu   <- truth$mean[,group_name][order(match(names(truth$mean[,group_name]),names(mu)))]
    obs.lo95 <- truth$lo95[,group_name][order(match(names(truth$lo95[,group_name]),names(mu)))]
    obs.hi95 <- truth$hi95[,group_name][order(match(names(truth$hi95[,group_name]),names(mu)))]

    #create plot

    plot(obs.mu ~ mu, cex = 0.7, ylim=c(0,limy), main=paste0('site-level ', group_name))
    arrows(c(mu), obs.lo95, c(mu), obs.hi95, length=0.05, angle=90, code=3)

      #r square best fit.
    fit.stats <- lm(obs.mu ~ mu)
      rsq <- round(summary(fit.stats)$r.squared,2)
      #r square 1:1.
      rss <- sum((mu -      obs.mu)  ^ 2)  ## residual sum of squares
      tss <- sum((obs.mu - mean(obs.mu)) ^ 2)  ## total sum of squares
      rsq1 <- 1 - rss/tss
      if(rsq1 < 0){rsq1 <- 0}
      #RMSE.
      rmse <- round(sqrt(mean(fit.stats$residuals^2)), 3)
    mtext(paste0('R2=',rsq, " RMSE=",rmse), cex = .7, side = 3, line = -2.7, adj = 0.03)
    #1:1 line
    abline(0,1, lwd = 2)
    # best-fit line.
    abline(lm(obs.mu ~mu), lty = 2, col = 'purple')
    #add confidence interval.
    range <- mu
    polygon(c(range, rev(range)),c(pi_0.975, rev(pi_0.025)), col=adjustcolor('green', trans), lty=0)
    polygon(c(range, rev(range)),c(ci_0.975, rev(ci_0.025)), col=adjustcolor('blue' , trans), lty=0)
    #fraction within 95% predictive interval.
    in_it <- round(sum(obs.mu < pi_0.975 & obs.mu > pi_0.025) / length(obs.mu),2) *100
    state <- paste0(in_it,'% of obs within interval.')
    mtext(state,side = 3,  cex = .7, line = -1.3, adj = 0.05)
    #}
    #mtext(paste0("Rsq for prior fit:", prior_rsq), cex = .7, side = 3, line = 1, outer = TRUE)
    #mtext(paste0("Present in ", present_percent[i], " of NEON cores."), cex = .7, side = 3, line = 0, outer = TRUE)
  }
}
dev.off()


# An exercise on species disribution modelling with Megachile sculpturalis
# Trying biomod2
# https://r-forge.r-project.org/scm/viewvc.php/*checkout*/pkg/biomod2/inst/doc/Simple_species_modelling.pdf?root=biomod
# Incomplete

# 05

# Libraries
library(biomod2)

# Params
map_crs = '+proj=longlat +datum=WGS84'
raster_dir = 'data/geo/1_separate/chelsa/bioclim/'
country_shp_dir = 'data/geo/1_separate/gadm/shp_pri'
data_in = 'data/2019-05-27-ejys-gbif-data/0018967-190415153152247-clean.csv'

# Read data
pres_dd = data.table::fread(data_in, integer64="character")
df_cols = names(pres_dd)
if(any(df_cols == "V1")) {
    pres_dd$V1 = NULL
}

# Subset presence data
native_range = c("JP", "KR", "CN", "TW")
pres_dd_native = pres_dd[countryCode %in% native_range]
pres_dd_native_sp = pres_dd_native

# Get extent
native_extent = raster::extent(min(pres_dd_native$decimalLongitude)-1,
                               max(pres_dd_native$decimalLongitude)+1,
                               min(pres_dd_native$decimalLatitude)-1,
                               max(pres_dd_native$decimalLatitude)+1)
native_extent_pol = methods::as(native_extent, 'SpatialPolygons')
crs(native_extent_pol) = map_crs

# Get background values
files = list.files(raster_dir, pattern="tif", full.names=TRUE)
predictors = raster::stack(files)
predictors = raster::crop(predictors, native_extent)
names(predictors) = paste0("bio", 1:19)
crs(predictors) = map_crs

x = as.matrix(pres_dd_native[ ,c("decimalLongitude", "decimalLatitude")])
x = data.frame(cbind(x, 1))
name = 'pres'
names(x) = c('x', 'y', name)

data = biomod2::BIOMOD_FormatingData(resp.var = x[,name],
                                     expl.var = predictors,
                                     resp.xy = x[,c('x', 'y')],
                                     resp.name = name)

# To be continued


[[[
 RELATIVE COMPLEXITY!
 Additional steps in my new construction for
 a self-delimiting universal Turing machine.

 We show that

    H(beta) <= n + H(n) + c for n-bit beta

    H(x,y) <= H(x) + H(y) + c

    H(H(x)|x) <= c

    H(x,y) <= H(x) + H(y|x) + c
]]]

[
 Here is the self-delimiting universal Turing machine
 with NO free data.  P is the program.
 [Run-utm-on p expands to this.]
]
define (U p)
   cadr try no-time-limit 'eval read-exp p

define      U
value       (lambda (p) (car (cdr (try no-time-limit (' (eval
            (read-exp))) p))))

[Here is the version of U with one piece of free data:]

define (U2 p q) [q is a program for U for the free data]
   cadr try no-time-limit
   display cons 'read-exp [run ((read-exp) (' q))]
           cons cons "'
                cons q
                nil
           nil
   p

define      U2
value       (lambda (p q) (car (cdr (try no-time-limit (displa
            y (cons (' (read-exp)) (cons (cons ' (cons q nil))
             nil))) p))))

[Here's the version given two things, not one:]

define (U3 p q r) [q, r are programs for U for the free data]
   cadr try no-time-limit
   display cons 'read-exp [run ((read-exp) (' q) (' r))]
           cons cons "'
                cons q
                nil
           cons cons "'
                cons r
                nil
           nil
   p

define      U3
value       (lambda (p q r) (car (cdr (try no-time-limit (disp
            lay (cons (' (read-exp)) (cons (cons ' (cons q nil
            )) (cons (cons ' (cons r nil)) nil)))) p))))

[
   Consider an n-bit string beta.
   We show that H(beta) <= n + H(n) + 912.
]
define pi
   let (loop k)
      if = k 0 nil
      cons read-bit (loop - k 1)
   (loop eval read-exp)

define      pi
value       ((' (lambda (loop) (loop (eval (read-exp))))) (' (
            lambda (k) (if (= k 0) nil (cons (read-bit) (loop
            (- k 1)))))))

[Size it.]
length bits pi

expression  (length (bits pi))
value       912

[Use it.]
(U
   append bits pi
   append bits 12
          '(0 0 1 1 1 1 1 1 0 0 0 1)
)

expression  (U (append (bits pi) (append (bits 12) (' (0 0 1 1
             1 1 1 1 0 0 0 1)))))
value       (0 0 1 1 1 1 1 1 0 0 0 1)

[
   Proof that H(x,y) <= H(x) + H(y) + 432.
]
define rho
   cons eval read-exp cons eval read-exp nil

define      rho
value       (cons (eval (read-exp)) (cons (eval (read-exp)) ni
            l))

[Size it.]
length bits rho

expression  (length (bits rho))
value       432

[Use it.]
(U
   append bits rho
   append bits pi
   append bits 5
   append '(1 1 1 1 1)
   append bits pi
   append bits 9
          '(0 0 0 0 0 0 0 0 0)
)

expression  (U (append (bits rho) (append (bits pi) (append (b
            its 5) (append (' (1 1 1 1 1)) (append (bits pi) (
            append (bits 9) (' (0 0 0 0 0 0 0 0 0)))))))))
value       ((1 1 1 1 1) (0 0 0 0 0 0 0 0 0))

[
   Proof that H(H(x)|x) <= 208.
]
define (alpha x*)     [x* = minimum-size program for x]
   length x*

define      alpha
value       (lambda (x*) (length x*))

         [get H(x) from x*]
[Size it.]
length bits alpha

expression  (length (bits alpha))
value       208

[Use it.]

(U2

[This is the program to calculate H(x):]

bits alpha

[This is the program x* for x,]
[supposedly smallest possible:]

bits' + 1 1

)

expression  (U2 (bits alpha) (bits (' (+ 1 1))))
display     ((read-exp) (' (0 0 1 0 1 0 0 0 0 0 1 0 1 0 1 1 0
            0 1 0 0 0 0 0 0 0 1 1 0 0 0 1 0 0 1 0 0 0 0 0 0 0
            1 1 0 0 0 1 0 0 1 0 1 0 0 1 0 0 0 0 1 0 1 0)))
value       64

[Check size of program is correct]
* 8 + 1 display size display '+ 1 1

expression  (* 8 (+ 1 (display (size (display (' (+ 1 1)))))))
display     (+ 1 1)
display     7
value       64

[
   Proof that H(x,y) <= H(x) + H(y|x) + 2872.

   The 2872-bit prefix gamma proves this.

   Gamma does the job, but it's slow.
   So below we will present delta, which is a greatly
   sped up version of gamma.  The speed up is
   achieved by introducing a new primitive function
   to do the job.  The was-read mechanism used below
   is much faster than our technique here using try
   to get the bits of the program p = x* as we run it.
]

define gamma

   [read program p bit by bit until we get it all]

   let (loop p)
      if = success car try no-time-limit 'eval read-exp p
      [then] p
      [else] (loop append p cons read-bit nil)

   let x* (loop nil)         [get x* = program for x]
   let x run-utm-on x*       [get x from x*]
   let y                     [get y from x* by running]
       eval cons 'read-exp   [((read-exp) (' x*))]
            cons cons "'
                 cons x*
                      nil
                 nil

   [form the pair x, y]
   cons x cons y nil

define      gamma
value       ((' (lambda (loop) ((' (lambda (x*) ((' (lambda (x
            ) ((' (lambda (y) (cons x (cons y nil)))) (eval (c
            ons (' (read-exp)) (cons (cons ' (cons x* nil)) ni
            l)))))) (car (cdr (try no-time-limit (' (eval (rea
            d-exp))) x*)))))) (loop nil)))) (' (lambda (p) (if
             (= success (car (try no-time-limit (' (eval (read
            -exp))) p))) p (loop (append p (cons (read-bit) ni
            l)))))))

[Size it.]
length bits gamma

expression  (length (bits gamma))
value       2872

[Use it.]

run-utm-on

[get pair x, y by combining                   ]
[a program for x and a program to get y from x]

append

   bits gamma

append

   [x* = program to calculate x = 2]
   [[Supposedly x* is smallest possible,]]
   [[but this works for ANY x* for x.]]

   bits' + 1 1

   [program to calculate y = x+1 from x*]

   bits' lambda(x*) + 1 run-utm-on x*

expression  (car (cdr (try no-time-limit (' (eval (read-exp)))
             (append (bits gamma) (append (bits (' (+ 1 1))) (
            bits (' (lambda (x*) (+ 1 (car (cdr (try no-time-l
            imit (' (eval (read-exp))) x*))))))))))))
value       (2 3)

[
   This technique for getting a program as well as its output
   by inching along using try is slow.

   Now let's speed up gamma by adding a new primitive function.
   Was-read gives the binary data read so far in the current try.
   With it we will prove that H(x,y) <= H(x) + H(y|x) + 2104.
]
define delta                 [knows that its own size is 2104 bits]
   let (skip n s)            [skip first n bits of bit string s]
       if = n 0 s (skip - n 1 cdr s) [used to erase delta from was-read]
   let x eval read-exp               [get x]
   let x* (skip 2104 was-read)       [get program for x]
   let y                     [calculate y from the program for x by]
       eval cons 'read-exp   [running ((read-exp) (' x*))]
            cons cons "'
                 cons x*
                 nil
            nil
   [form the pair x, y]
   cons x cons y nil

define      delta
value       ((' (lambda (skip) ((' (lambda (x) ((' (lambda (x*
            ) ((' (lambda (y) (cons x (cons y nil)))) (eval (c
            ons (' (read-exp)) (cons (cons ' (cons x* nil)) ni
            l)))))) (skip 2104 (was-read))))) (eval (read-exp)
            )))) (' (lambda (n s) (if (= n 0) s (skip (- n 1)
            (cdr s))))))

[Size it.]
length bits delta

expression  (length (bits delta))
value       2104

[Use it.]

run-utm-on

[get pair x, y by combining                   ]
[a program for x and a program to get y from x]

append

   bits delta

append

   [x* = program to calculate x = 2]
   [[Supposedly x* is smallest possible,]]
   [[but this works for ANY x* for x.]]

   bits' + 1 1

   [program to calculate y = x+1 from x*]

   bits' lambda(x*) + 1 run-utm-on x*

expression  (car (cdr (try no-time-limit (' (eval (read-exp)))
             (append (bits delta) (append (bits (' (+ 1 1))) (
            bits (' (lambda (x*) (+ 1 (car (cdr (try no-time-l
            imit (' (eval (read-exp))) x*))))))))))))
value       (2 3)


#' @title convert.datecodes
#' @description This function take a chron object x and extract required data
#' @param \code{x} = a chron date object
#' @param \code{y} = the value to be extracted x, acceptable values include 'chron', 'year','month','day','week','julian','julian.ref.2000','tripcode'
#' @return \code{z} =  the requested date part
#' @examples
#' t=Sys.Date()
#' convert.datecodes(t,'year')
#' [1] 2016
#' convert.datecodes(t,'week')
#' [1] 25
#' @author  unknown, \email{<unknown>@@dfo-mpo.gc.ca}
#' @family date functions
#' @export
convert.datecodes = function (x, y) {
  require(chron)
  q = month.day.year(x)
  j = julian( x=q$month, d=q$day, y=q$year )
  z=NULL
  if (y=="chron") z = q
  if (y=="year") z = q$year
  if (y=="month") z = q$month
  if (y=="day") z = q$day
  if (y=="week") {
    z = round( convert.datecodes( x, y="julian" ) / 365 * 52) + 1
  }
  if (y=="julian") {
    z = j - julian(x=rep(1,length(q$year)), d=rep(1,length(q$year)), y=q$year)
    z = z + 1
    i = which(z > 365)
    z[i]= z[i] - 1
    j = which(z > 365)
    if ( length(j) > 1 ) print ("error in dates")
  }
  if (y=="julian.ref.2000") z = 1 + j - julian(x=rep(1,length(q$year)), d=rep(1,length(q$year)), y=rep.int(2000,length(q$year)))
  if (y=="tripcode") {
    day = as.character( convert.datecodes(x, "day") )
    day = ifelse( nchar(day) == 1, paste("0", day, sep=""), day)
    month =  as.character( convert.datecodes(x, "month") )
    month = ifelse( nchar(month) == 1, paste("0", month, sep=""), month)
    z = paste( "S", day,  month, convert.datecodes(x, "year"), sep="")
  }

  return (z)
}


palindro <- function(p) {
  if ( nchar(p) == 1 ) {
    return(TRUE)
  } else if ( nchar(p) == 2 ) {
    return(substr(p,1,1) == substr(p,2,2))
  } else {
    if ( substr(p,1,1) == substr(p, nchar(p), nchar(p)) ) {
      return(palindro(substr(p, 2, nchar(p)-1)))
    } else {
      return(FALSE)
    }
  }
}


expr1 <- quote(a+b*c)
expr2 <- parse(text="a+b*c")[[1]]
expr3 <- call("+", quote(`a`), call("*", quote(`b`), quote(`c`)))


source('positiveNumberValidator.r')

budget = setRefClass("budget",
  contains = "positiveNumberValidator",
  fields = list(
    netMonthlyRevenue = 'numeric',
    monthlySpend = 'numeric',
    monthlySavings = 'numeric',
    availableBudget = 'numeric'
  ),
  methods = list(
    initialize = function(nMr, mSp, mSa){
      validateInputs(nMr, mSp, mSa)

      netMonthlyRevenue <<- nMr
      monthlySpend <<- mSp
      monthlySavings <<- mSa
      availableBudget <<- netMonthlyRevenue - monthlySpend - monthlySavings
    },
    validateInputs = function(nMr, mSp, mSa){
      validateNumber(nMr)
      validateNumber(mSp)
      validateNumber(mSa)
    }
  )
)

renderBudgetInput = function(title, nMrId, mSpId, mSaId){
  fluidRow(
    column(12,
      h4(title, style = "margin-top: 0px; border-bottom: 1px solid #e3e3e3;"),
      numericInput(nMrId, "Net Monthly Revenue ($)", 3000, min = 0),
      numericInput(mSpId, "Monthly Spend ($)", 0, min = 0),
      numericInput(mSaId, "Monthly Savings ($)", 0, min = 0),
    )
  )
}


MM_MTX_INT =      1L

MM_SPARSE_INT =   11L
MM_DENSE_INT =    12L

MM_COMPLEX_INT =  101L
MM_REAL_INT =     102L
MM_PATTERN_INT =  103L
MM_INT_INT =      104L

MM_SYMM_INT =     1001L
MM_GENERAL_INT =  1002L
MM_SKEW_INT =     1003L
MM_HERM_INT =     1004L

MM_MTX_CHAR =     'M'

MM_SPARSE_CHAR =  'C'
MM_DENSE_CHAR =   'A'

MM_COMPLEX_CHAR = 'C'
MM_REAL_CHAR =    'R'
MM_PATTERN_CHAR = 'P'
MM_INT_CHAR =     'I'

MM_SYMM_CHAR =    'S'
MM_GENERAL_CHAR = 'G'
MM_SKEW_CHAR =    'K'
MM_HERM_CHAR =    'H'

mm_matcode_char2int = function(matcode)
{
  intcode = integer(4)

  if (mm_is_matrix(matcode))
    intcode[1] = MM_MTX_INT
  else
    stop("unsupported type")

  if (mm_is_sparse(matcode))
    intcode[2] = MM_SPARSE_INT
  else if (mm_is_dense(matcode))
    intcode[2] = MM_DENSE_INT
  else
    stop("unsupported type")

  if (mm_is_real(matcode))
    intcode[3] = MM_REAL_INT
  else if (mm_is_complex(matcode))
    intcode[3] = MM_COMPLEX_INT
  else if (mm_is_pattern(matcode))
    intcode[3] = MM_PATTERN_INT
  else if (mm_is_integer(matcode))
    intcode[3] = MM_INT_INT
  else
    stop("unsupported type")

  if (mm_is_general(matcode))
    intcode[4] = MM_GENERAL_INT
  else if (mm_is_symmetric(matcode))
    intcode[4] = MM_SYMM_INT
  else if (mm_is_hermitian(matcode))
    intcode[4] = MM_HERM_INT
  else if (mm_is_skew(matcode))
    intcode[4] = MM_SKEW_INT
  else
    stop("unsupported type")

  intcode
}

mm_matcode_int2char = function(intcode)
{
  matcode = character(4)

  if (intcode[1] == MM_MTX_INT)
    matcode[1] = MM_MTX_CHAR
  else
    stop("unsupported type")

  if (intcode[2] == MM_SPARSE_INT)
    matcode[2] = MM_SPARSE_CHAR
  else if (intcode[2] == MM_DENSE_INT)
    matcode[2] = MM_DENSE_CHAR
  else
    stop("unsupported type")

  if (intcode[3] == MM_REAL_INT)
    matcode[3] = MM_REAL_CHAR
  else if (intcode[3] == MM_COMPLEX_INT)
    matcode[3] = MM_COMPLEX_CHAR
  else if (intcode[3] == MM_PATTERN_INT)
    matcode[3] = MM_PATTERN_CHAR
  else if (intcode[3] == MM_INT_INT)
    matcode[3] = MM_INT_CHAR
  else
    stop("unsupported type")

  if (intcode[4] == MM_GENERAL_INT)
    matcode[4] = MM_GENERAL_CHAR
  else if (intcode[4] == MM_SYMM_INT)
    matcode[4] = MM_SYMM_CHAR
  else if (intcode[4] == MM_HERM_INT)
    matcode[4] = MM_HERM_CHAR
  else if (intcode[4] == MM_SKEW_INT)
    matcode[4] = MM_SKEW_CHAR
  else
    stop("unsupported type")

  matcode
}

write_mm = function(f, mm)
{
  mm_write_mtx_crd(f, mm$M, mm$N, mm$nz, mm$I, mm$J, mm$val, mm$matcode)
}

read_mm = function(f)
{
  mm = mm_read_mtx_crd(f)
  ind = order(mm$I)
  mm$I = mm$I[ind]
  mm$J = mm$J[ind]

  # TODO FIXME
  mm$indexing = min(1L, min(mm$I), min(mm$J))

  mm
}