readacpfp=function(){

# R Program to read in HIPPO, ORCAS, and ATom PFP merge files, massage time variables, add a strat flag, subset, and write to RData object for use by aircraft_filter_mspo_pfp.r

library('ncdf4')

# specify aircraft data file names
localdatadir='local-data-files'
hippomergefile=paste(localdatadir,'/aircraft-merge-products/HIPPO_noaa_flask_allparams_merge_insitu_20121129.tbl',sep='') # this is the official HIPPO merge product
atommergedir=paste(localdatadir,'/aircraft-merge-products',sep='') # these are version 2.0 (21-08-26)
atommergefiles=c('MER-PFP_DC8_ATom-2.nc','MER-PFP_DC8_ATom-3.nc','MER-PFP_DC8_ATom-4.nc') # no ATom-1 PFP data
# no ORCAS PFP data

# set strat flag cutoffs for use below based upon Jin et al., 2021 (https://doi.org/10.5194/acp-21-217-2021)
stratcoh2o=50
stratcoo3=150
stratcon2o=319

# read in global N2O for detrending aircraft N2O
glbn2ofile=url('ftp://aftp.cmdl.noaa.gov/products/trends/n2o/n2o_annmean_gl.txt')
hlines=61
glbn2o=read.table(glbn2ofile,skip=hlines,header=F,stringsAsFactors=F)
colnames(glbn2o)=c('year','n2o','unc')

# for HIPPO, need to interpolate prof variable from 10-sec merge - load from read_aircraft_10s.r output before reading PFP data below
if(file.exists('HIPPO_10s.RData')){
	load('HIPPO_10s.RData')
} else {
        source('read_aircraft10s.r')
        readac10s()
}
hippomerge10s=hippomerge # 'hippomerge' reused below
# names(hippomerge)=c('year','mon','day','hour','min','sec','camp','flt','prof','lat','lon','alt','pressure','theta','co2','co2qcls','co2oms','co2ao2','ch4qcls','ch4ucats','ch4panther','sf6panther','sf6ucats','sf6pfp','strat','h2oref','n2oref','o3ref') ## 'co2' = CO2.X
hippo10sdt=ISOdatetime(hippomerge$year,hippomerge$mon,hippomerge$day,hippomerge$hour,hippomerge$min,hippomerge$sec,tz='UTC')

## read in HIPPO file, calc strat flag, subset, and output
print('Reading HIPPO file')

# read and add time variables
hippomerge=read.table(hippomergefile,header=T)
hippodt=strptime(paste(hippomerge[,"Year"],hippomerge[,"DOY"]),format='%Y %j',tz='UTC')+hippomerge[,"UTC"] # DOY is day of year of takeoff; UTC is seconds since midnight on day of takeoff
hippomerge$Month=as.POSIXlt(hippodt)$mon+1
hippomerge$Day=as.POSIXlt(hippodt)$mday
hippomerge$Hour=as.POSIXlt(hippodt)$hour
hippomerge$Min=as.POSIXlt(hippodt)$min
hippomerge$Sec=as.POSIXlt(hippodt)$sec

# interpolate prof from 10 sec file
hippomerge$prof=approx(as.POSIXct(hippo10sdt),hippomerge10s$prof,as.POSIXct(hippodt),method='constant',f=0)$y

# add strat flag
hippomerge$strat=rep(0,nrow(hippomerge)) # 0 means trop
h2oref=hippomerge$H2Oppmv_vxl; h2oref[is.na(h2oref)]=hippomerge$H2O_UWV[is.na(h2oref)]
hippomerge$h2oref=h2oref # for output
h2oref[is.na(h2oref)]=0 # if H2O missing treat as if potentially strat
n2oref=hippomerge$N2O_CCG; n2oref[is.na(n2oref)]=hippomerge$N2O_QCLS[is.na(n2oref)]
n2oref=n2oref-(approx(glbn2o$year+0.5,glbn2o$n2o,hippomerge$Year+hippomerge$DOY/365)$y-glbn2o$n2o[glbn2o$year==2009])
hippomerge$n2oref=n2oref # for output
n2oref[is.na(n2oref)]=400 # if N2O missing do not use for filter
o3ref=hippomerge$O3_ppb; o3ref[is.na(o3ref)]=hippomerge$O3_UO3[is.na(o3ref)]
hippomerge$o3ref=o3ref # for output
o3ref[is.na(o3ref)]=0 # if O3 missing do not use for filter
hippomerge$strat[h2oref<stratcoh2o&(o3ref>stratcoo3|n2oref<stratcon2o|(o3ref==0&n2oref==400))]=1 # if either o3 or n2o criteria are met, or if both are missing, consider strat
hippomerge$strat[h2oref==0&o3ref==0&n2oref==400&hippomerge$GGALT<8000]=0 # if all 3 missing assume < 8 km is trop

# select columns and save
colsel=c('Year','Month','Day','Hour','Min','Sec','H.no','flt','prof','GGLAT','GGLON','GGALT','PSXC','THETA','CO2_CCG','CO2_QCLS','CO2_OMS','CO2_AO2','CH4_CCG','CH4_QCLS','SF6_CCG','strat','h2oref','n2oref','o3ref')
hippomerge=hippomerge[,is.element(colnames(hippomerge),colsel)]
hippomerge=hippomerge[,match(colsel,names(hippomerge))] # reorder
names(hippomerge)=c('year','mon','day','hour','min','sec','camp','flt','prof','lat','lon','alt','pressure','theta','co2','co2qcls','co2oms','co2ao2','ch4pfp','ch4qcls','sf6pfp','strat','h2oref','n2oref','o3ref') ## 'co2' = CO2_CCG = co2pfp
save('hippomerge',file='HIPPO_PFP.RData')

## read in ATom files, calc strat flag, subset, and output
print('Reading ATom files')

# read and add time variables
atomvar=c('time','Flight_Date','DLH-H2O/H2O_DLH','UCATS-H2O/H2O_UWV','UCATS-O3/O3_UCATS','QCLS-CH4-CO-N2O/N2O_QCLS','NOyO3-O3/O3_CL','MMS/G_ALT','RF','prof.no','MMS/P','MMS/POT','MMS/G_LAT','MMS/G_LONG','MMS/G_ALT','NOAA-Picarro/CO2_NOAA','QCLS-CO2/CO2_QCLS','AO2/CO2_AO2','CO2.X','NOAA-Picarro/CH4_NOAA','QCLS-CH4-CO-N2O/CH4_QCLS','PFP/CO2_PFP','PFP/CH4_PFP','PFP/N2O_PFP','PFP/SF6_CCGG_PFP')
atommerge=NULL
for(i in c(1:3)){
	atomnc=nc_open(paste(atommergedir,'/',atommergefiles[i],sep=''))
       	count=length(ncvar_get(atomnc,'time'))
	campdata=NULL
        for(var in atomvar){
		campdata=cbind(campdata,ncvar_get(atomnc,var))
        }
	campdata=cbind(campdata,rep(i+1,count)) # A.no
       	nc_close(atomnc)
	atommerge=rbind(atommerge,campdata)
}
atommerge=data.frame(atommerge,stringsAsFactors=F)
names(atommerge)=c(gsub('.*/','',atomvar),'A.no')
atommerge$YYYYMMDD=atommerge$Flight_Date
atomdt=as.POSIXlt(ISOdatetime(2016,1,1,0,0,0,tz='UTC')+atommerge$time,tz='UTC')
atommerge$Year=atomdt$year+1900
atommerge$Month=as.POSIXlt(atomdt)$mon+1
atommerge$Day=as.POSIXlt(atomdt)$mday
atommerge$Hour=as.POSIXlt(atomdt)$hour
atommerge$Min=as.POSIXlt(atomdt)$min
atommerge$Sec=as.POSIXlt(atomdt)$sec

# add strat flag
atommerge$strat=rep(0,nrow(atommerge)) # 0 means trop
h2oref=atommerge$H2O_DLH; h2oref[is.na(h2oref)]=atommerge$H2O_UWV[is.na(h2oref)]
atommerge$h2oref=h2oref # for output
h2oref[is.na(h2oref)]=0 # if H2O missing treat as if potentially strat
n2oref=atommerge$N2O_QCLS; n2oref[is.na(n2oref)]=atommerge$N2O_PFP[is.na(n2oref)]
n2oref=n2oref-(approx(glbn2o$year+0.5,glbn2o$n2o,atommerge$Year+atomdt$yday/365)$y-glbn2o$n2o[glbn2o$year==2009])
atommerge$n2oref=n2oref # for outptut
n2oref[is.na(n2oref)]=400 # if N2O missing do not use for filter
o3ref=atommerge$O3_CL; o3ref[is.na(o3ref)]=atommerge$O3_UCATS[is.na(o3ref)]

atommerge$o3ref=o3ref
o3ref[is.na(o3ref)]=0 # if O3 missing do not use for filter
atommerge$strat[h2oref<stratcoh2o&(o3ref>stratcoo3|n2oref<stratcon2o|(o3ref==0&n2oref==400))]=1 # if either o3 or n2o criteria are met, or if both are missing, consider strat
atommerge$strat[h2oref==0&o3ref==0&n2oref==400&atommerge$G_ALT<8000]=0 # if all 3 missing assume < 8 km is trop

# select column and save
colsel=c('Year','Month','Day','Hour','Min','Sec','A.no','RF','prof.no','G_LAT','G_LONG','G_ALT','P','POT','CO2_PFP','CO2_NOAA','CO2_QCLS','CO2_AO2','CH4_PFP','CH4_NOAA','CH4_QCLS','SF6_CCGG_PFP','strat','h2oref','n2oref','o3ref')
atommerge=atommerge[,is.element(colnames(atommerge),colsel)]
atommerge=atommerge[,match(colsel,names(atommerge))] # reorder
names(atommerge)=c('year','mon','day','hour','min','sec','camp','flt','prof','lat','lon','alt','pressure','theta','co2','co2noaa','co2qcls','co2ao2','ch4pfp','ch4noaa','ch4qcls','sf6pfp','strat','h2oref','n2oref','o3ref') ## 'co2' = CO2_PFP
save('atommerge',file='ATom_PFP.RData')

} # end of readacPFP function


#t_pulse是单次射出所需的时间
#t_pulse，随着电压频率fv的上升而改变；随着流量而改变；

#以流量为划分

#设定工作目录
setwd("D:/data")
library(xlsx)

#读取数据
eq15<-read.xlsx("t_pulse.xls", sheetName = "eject_q15", header = TRUE)
eq27<-read.xlsx("t_pulse.xls", sheetName = "eject_q27", header = TRUE)
eq54<-read.xlsx("t_pulse.xls", sheetName = "eject_q54", header = TRUE)
eq180<-read.xlsx("t_pulse.xls", sheetName = "eject_q180", header = TRUE)

#设定空间位置
par(mfrow = c(2,2), mar = c(4,4,2,2), oma = c(2,2,2,2))

############1.5nl/min#######
##################################画图--占空比k为1.5nl/min#######################
plot(eq15$fv, eq15$X0.2, xaxs = "i", col = 0, xlab = "Voltage frequency (Hz)", ylab = "Eject time t_eject (ms)", main = "Eject time in Q = 1.5nl/min", cex.lab = 1.1, cex.main = 1.2, xlim = c(0, 250), ylim = c(0.1, 82))

#model1 = loess(eq15$X0.2 ~ eq15$fv, span = 0.8 , degree = 2)
lines(eq15$fv, eq15$X0.2,  col="#458B74",lwd=2, type="l", lty=3)

#model2 = loess(eq15$X0.3 ~ eq15$fv, span = 0.8, degree = 2)
lines(eq15$fv, eq15$X0.3, col="#FF00FF", lwd=2, type="l", lty=3)

#model3 = loess(eq15$X0.4 ~ eq15$fv, span = 0.8, degree = 2)
lines(eq15$fv, eq15$X0.4, col="#EE0000", lwd=2, type="l", lty=3)

#model4 = loess(eq15$X0.5 ~ eq15$fv, span = 0.8, degree =2)
lines(eq15$fv, eq15$X0.5, col="#27408B", lwd=2, type="l", lty=3)

#区域划线
legend("topright", c("k = 0.2", "k = 0.3", "k = 0.4", "k = 0.5"), col = c("#458B74", "#FF00FF", "#EE0000", "#27408B"), pch = c(21, 22, 23, 24), lwd = 2, lty = 2, cex = 1.1, inset = .03, bty = "n")

##################################画图--占空比k为27nl/min#######################
plot(eq27$fv, eq27$X0.2, xaxs = "i", col = 0, xlab = "Voltage frequency (Hz)", ylab = "Eject time t_eject (ms)", main = "Eject time in Q = 27nl/min", cex.lab = 1.1, cex.main = 1.2, xlim = c(0, 250), ylim = c(0.1, 80))

#model1 = loess(eq27$X0.2 ~ eq27$fv, span = 0.8 , degree = 2)
lines(eq27$fv, eq27$X0.2,  col="#458B74", lwd=2, type="l", lty=3)

#model2 = loess(eq27$X0.3 ~ eq27$fv, span = 0.8, degree = 2)
lines(eq27$fv, eq27$X0.3, col="#FF00FF", lwd=2, type="l", lty=3)

#model3 = loess(eq27$X0.4 ~ eq27$fv, span = 0.8, degree = 2)
lines(eq27$fv, eq27$X0.4, col="#EE0000", lwd=2, type="l", lty=3)

#model4 = loess(eq27$X0.5 ~ eq27$fv, span = 0.8, degree =2)
lines(eq27$fv, eq27$X0.5, col="#27408B", lwd=2, type="l", lty=3)

#区域划线
legend("topright", c("k = 0.2", "k = 0.3", "k = 0.4", "k = 0.5"), col = c("#458B74", "#FF00FF", "#EE0000", "#27408B"), pch = c(21, 22, 23, 24), lwd = 2, lty = 2, cex = 1.1, inset = .03, bty = "n")

##################################画图--占空比k为54nl/min#######################
plot(eq54$fv, eq54$X0.2, xaxs = "i", col = 0, xlab = "Voltage frequency (Hz)", ylab = "Eject time t_eject (ms)", main = "Eject time in Q = 54nl/min", cex.lab = 1.1, cex.main = 1.2, xlim = c(0, 250), ylim = c(0.1, 82))

#model1 = loess(eq54$X0.2 ~ eq54$fv, span = 0.8 , degree = 2)
lines(eq54$fv, eq54$X0.2,  col="#458B74", lwd=2, type="l", lty=3)

#model2 = loess(eq54$X0.3 ~ eq54$fv, span = 0.8, degree = 2)
lines(eq54$fv, eq54$X0.3, col="#FF00FF", lwd=2, type="l", lty=3)

#model3 = loess(eq54$X0.4 ~ eq54$fv, span = 0.8, degree = 2)
lines(eq54$fv, eq54$X0.4, col="#EE0000", lwd=2, type="l", lty=3)

#model4 = loess(eq54$X0.5 ~ eq54$fv, span = 0.8, degree =2)
lines(eq54$fv, eq54$X0.5, col="#27408B", lwd=2, type="l", lty=3)

#区域划线
legend("topright", c("k = 0.2", "k = 0.3", "k = 0.4", "k = 0.5"), col = c("#458B74", "#FF00FF", "#EE0000", "#27408B"), pch = c(21, 22, 23, 24), lwd = 2, lty = 2, cex = 1.1, inset = .03, bty = "n")

##################################画图--占空比k为180nl/min#######################
plot(eq180$fv, eq180$X0.2, xaxs = "i", col = 0, xlab = "Voltage frequency (Hz)", ylab = "Eject time t_eject (ms)", main = "Eject time in Q = 180nl/min", cex.lab = 1.1, cex.main = 1.2, xlim = c(0, 250), ylim = c(0.1, 90))

#model1 = loess(eq180$X0.2 ~ eq180$fv, span = 0.8 , degree = 2)
lines(eq180$fv, eq180$X0.2,  col="#458B74", lwd=2, type="l", lty=3)

#model2 = loess(eq180$X0.3 ~ eq180$fv, span = 0.8, degree = 2)
lines(eq180$fv, eq180$X0.3, col="#FF00FF", lwd=2, type="l", lty=3)

#model3 = loess(eq180$X0.4 ~ eq180$fv, span = 0.8, degree = 2)
lines(eq180$fv, eq180$X0.4, col="#EE0000", lwd=2, type="l", lty=3)

#model4 = loess(eq180$X0.5 ~ eq180$fv, span = 0.8, degree =2)
lines(eq180$fv, eq180$X0.5, col="#27408B", lwd=2, type="l", lty=3)

#区域划线
legend("topright", c("k = 0.2", "k = 0.3", "k = 0.4", "k = 0.5"), col = c("#458B74", "#FF00FF", "#EE0000", "#27408B"), pch = c(21, 22, 23, 24), lwd = 2, lty = 2, cex = 1.1, inset = .03, bty = "n")


require(shiny)
require(leaflet)

shinyServer(function(input, output) {

  points <- eventReactive(input$recalc, {
    cbind(rnorm(40) * 2 + 13, rnorm(40) + 48)
  }, ignoreNULL = FALSE)

  output$mymap <- renderLeaflet({
    leaflet() %>%
      addProviderTiles("Stamen.TonerLite",
                       options = providerTileOptions(noWrap = TRUE)
      ) %>%
      addMarkers(data = points())
  })
})

# shinyServer(function(input, output){
#
#   # factor out code common to all functions.
#   species2 <- reactive({
#     strsplit(input$spec, ",")[[1]]
#   })
#
#   occur_data <- reactive({
#     rcharts_prep1(sppchar = input$spec, occurrs = input$numocc, datasource = input$datasource)
#   })
#
#   rcharts_data <- reactive({
#     rcharts_prep2(occur_data(), palette_name = get_palette(input$palette), popup = TRUE)
#   })
#
#   output$map_leaflet <- renderMap({
#     imap = gbifmap2(input = rcharts_data(), input$provider)
#     imap$legend(
#       position = 'bottomright',
#       colors = get_colors(species2(), get_palette(input$palette)),
#       labels = species2()
#     )
#     imap
#   })
#
# })


semantic_tracking_mgr<-function(df,fileroot){
# Description
# Manages semantic data generation and upload to semantic tracking table
# arguments
# df - dataframe with the instances of database being uploaded and the column names as ENGINE_ID$ENGINE_NAME$TABLE$COLUMN
# fileroot - name of the file root for the data items history will be saved to
	column_doc_mgr_dopar(df,fileroot)
	datasemantic_history(fileroot)
}

datasemantic_history<-function(fileroot){
# Description
# Extract from GA tracking data queries data items history
# Arguments
# df - structure of db being uploaded
# fileroot - name of the file root for the data items history will be saved to
	sep<-"$"
	paste2 <- function(x, y, sep = " ") paste(x, y, sep = sep)

	df_desc<-readRDS(paste0(fileroot,"-description.rds"))
	n<-nrow(df_desc)
	if(n>0){
		# Create a dataframe that will contain the semantic info
		df<-as.data.frame(sapply(strsplit(df_desc$Original_Column, "[$]"), "[", 1))
		colnames(df)[1]<-"ENGINE_ID"
		df$ENGINE_ID<-sapply(strsplit(df_desc$Original_Column, "[$]"), "[", 1)
		df$ENGINE_NAME<-sapply(strsplit(df_desc$Original_Column, "[$]"), "[", 2)
		df$TABLE_NAME<-sapply(strsplit(df_desc$Original_Column, "[$]"), "[", 3)
		df$COLUMN_NAME<-sapply(strsplit(df_desc$Original_Column, "[$]"), "[", 4)
		df$Original_Column<-df_desc$Original_Column
		df<-unique(df)
		m<-nrow(df)
		for(i in 1:m){
			col<-as.character(df[i,"Original_Column"])
			col_desc<-df_desc[df_desc$Original_Column == col,2]
			if(length(col_desc)>0){
				desc<-Reduce(paste2,col_desc)
				df[i,"DESCRIPTION"]<-desc
			}
		}
	}
	if(nrow(df) > 0){
		found<-TRUE
		filename<-paste0(fileroot,"-semantic-history.rds")
		if(file.exists(filename)){
			# update to remove all existing tables of there are any updates to  them
			df$Original_Column<-paste(df$ENGINE_ID,df$ENGINE_NAME,df$TABLE,sep="$")
			exist_df<-readRDS(filename)
			exist_df$Original_Column<-paste(exist_df$ENGINE_ID,exist_df$ENGINE_NAME,exist_df$TABLE,sep="$")
			exist_df<-exist_df[!(exist_df$Original_Column %in% df$Original_Column),]
			exist_df<-rbind(exist_df,df)
			exist_df<-exist_df[,!(colnames(exist_df) == "Original_Column")]
			saveRDS(exist_df,filename)
		}else{
			df<-df[,!(colnames(df) == "Original_Column")]
			saveRDS(df,filename)
		}
	}else{
		found<-FALSE
	}
	gc()
	return(found)
}

column_lsi_mgr<-function(fileroot,desc_col,freq_col,share,weighted=TRUE){
# Description
# Builds LSA space for the semantic history column info
# Arguments
# fileroot - the root of family of feles supporting the data recommendation
# desc_col - the name of the column with description data
# freq_col - the name of the column with description frequency data
# share - the approximation used in matrix factorization
# weighted - whether to use term frequency inverse document frequency transformation
	filename<-paste0(fileroot,"-semantic-history.rds")
	if(file.exists(filename)){
		r<-readRDS(filename)
		if(nrow(r)>0){
			filename_lsa<-paste0(fileroot,"-lsa")
			cmd<-paste0("r$",freq_col,"<-1")
			eval(parse( text=cmd ))
			r$Original_Column<-paste(r[,1],r[,2],r[,3],r[,4],sep="$")
			lsi_mgr(r,desc_col,freq_col,share,filename_lsa,weighted)
		}else{
			print("Semantic history data not found")
		}
	}
}

compute_column_desc_sim<-function(fileroot){
# Description
# Constructs similarity matrix based on column LSA info
# Arguments
# fileroot - the root of family of files supporting the data recommendation
	library(lsa)
	filename<-paste0(fileroot,"-semantic-history.rds")
	if(file.exists(filename)){
		exist_df<-readRDS(filename)
		exist_df$Original_Column<-paste(exist_df[,1],exist_df[,2],exist_df[,3],exist_df[,4],sep="$")
		lsa<-readRDS(paste0(fileroot,"-lsa.rds"))
		dk<-lsa$dk
		sim<-cosine(t(dk))
		sim[which(is.nan(sim))]=0
		columns<-unique(as.character(exist_df$Original_Column))
		rownames(sim)<-columns
		colnames(sim)<-columns
		saveRDS(sim,paste0(fileroot,"-sim.rds"))
	}
	gc()
}

compute_entity_sim<-function(fileroot,type="database",sep="$"){
# Description
# Constructs entity similarity matrix based on column similarity matrix
# Arguments
# fileroot - the root of family of feles supporting the data recommendation
# type - entity type
# sep - separator used for parsing
	filename<-paste0(fileroot,"-sim.rds")
	if(file.exists(filename)){
		r<-readRDS(filename)
		cols<-rownames(r)
		if(tolower(type) == "table"){
			tbls<-unique(col2tbl(cols,sep))
		}else if(tolower(type) == "database"){
			tbls<-unique(col2db(cols,sep))
		}else{
			return("Please provide correct entity type: table or database")
		}
		n<-length(tbls)
		sim<-diag(rep(1,n))
		rownames(sim)<-tbls
		colnames(sim)<-tbls
		if(n > 1){
			for(i in 1:n){
				tbl1<-tbls[i]
				for(j in 1:n){
					if(i !=j){
						tbl2<-tbls[j]
						n1<-nchar(tbl1)
						n2<-nchar(tbl2)
						ind1<-append(which(cols %in% cols[nchar(cols)==n1]),which(cols %in% cols[substr(cols,(n1+1),(n1+1))==sep]))
						dim1<-intersect(which(substr(cols,1,nchar(tbl1)) == tbl1),ind1)
						ind2<-append(which(cols %in% cols[nchar(cols)==n2]),which(cols %in% cols[substr(cols,(n2+1),(n2+1))==sep]))
						dim2<-intersect(which(substr(cols,1,nchar(tbl2)) == tbl2),ind2)
						if(length(dim1) == 1){
							value=max(r[dim1,dim2])
						}else{
							m<-as.matrix(r[dim1,][,dim2])
							value<-mean(apply(m,1,max))
						}
						sim[i,j]<-value
					}
				}
			}
		}
		saveRDS(sim,paste0(fileroot,"-",type,"-sim.rds"))
		gc()
	}
}

col2tbl<-function(col,sep="$"){
# Description
# Extract from the column label table label
# Arguments
# col - column name to parse
	items<-strsplit(col,paste0("[",sep,"]"))
	n<-length(items)
	tbls<-vector()
	for(i in 1:n){
		if(length(items[[i]]) > 1){
			tbls[i]<-paste0(items[[i]][1],sep,items[[i]][2])
		}else{
			tbls[i]<-items[[i]][1]
		}
	}
	gc()
	return(tbls)
}

col2db<-function(col,sep="$"){
# Description
# Extract from the column label database label
# Arguments
# col - column name to parse
	items<-strsplit(col,paste0("[",sep,"]"))
	n<-length(items)
	dbs<-vector()
	for(i in 1:n){
		dbs[i]<-items[[i]][1]
	}
	gc()
	return(dbs)
}

column_doc_mgr_dopar<-function(df,fileroot,choice="both"){
# Description
# Generates wikidata/google descriptions based on provided instances using parallel processing
# Arguments
# df - dataframe containing available instances
# fileroot - the root of the family of file providing data recommendations
# choice - specifies whether use wiki, google r both to generate the descriptions
	library(doParallel)
	library(XML)
	library(RCurl)
	library(stringr)

	clusterDesc<-function(colname,values,choice){
		if(tolower(choice) == "both"){
			t<-create_column_doc(colname,values)
			if(nrow(t) == 0){
				t<-construct_column_doc(colname,values)
			}
		}else if(tolower(choice) == "wiki"){
			t<-create_column_doc(colname,values)
		}else{
			t<-construct_column_doc(colname,values)
		}
		return(t)
	}

	n<-ncol(df)
	# determine the number of physical cores
	cores <- detectCores(logical = FALSE)
	cl <- makeCluster(cores)
	registerDoParallel(cl, cores=cores)

	r<-foreach(i=1:n, .init=data.frame(),.combine=rbind, .export=c("create_column_doc","construct_column_doc","discover_column_desc","getSearchURL")) %dopar%
	{
		values<-as.character(df[[i]])
		values<-gsub("_"," ",values)
		colname<-colnames(df)[i]
		clusterDesc(colname,values,choice)
	}
	stopImplicitCluster()
	stopCluster(cl)

	filename<-paste0(fileroot,"-description.rds")
	if(file.exists(filename)){
		exist_df<-readRDS(filename)
		exist_df<-exist_df[!(exist_df$Original_Column %in% r$Original_Column),]
		exist_df<-rbind(exist_df,r)
		saveRDS(exist_df,filename)
	}else{
		saveRDS(r,filename)
	}
	gc()
	return(r)
}

column_doc_mgr_do<-function(df,fileroot,choice="both"){
# Description
# Generates wikidata/google descriptions based on provided instances using
# Arguments
# df - dataframe containing available instances
# fileroot - the root of the family of file providing data recommendations
# choice - specifies whether use wiki, google r both to generate the descriptions
	library(XML)
	library(RCurl)
	library(stringr)
	n<-ncol(df)
	r<-data.frame()
	#tempName<-Reduce("paste0",sample(letters,26))
	tempName<-constructName()
	for(i in 1:n){
		# save original column name in case it has special characters
		colname<-colnames(df)[i]
		# Operate with temporary column name
		colnames(df)[i]<-tempName
		cmd<-paste0("values<-as.character(df$",tempName,")")
		eval(parse( text=cmd ))
		values<-gsub("_"," ",values)
		colnames(df)[i]<-colname
		if(tolower(choice) == "both"){
			t<-create_column_doc(colname,values)
			if(nrow(t) == 0){
				t<-construct_column_doc(colname,values)
			}
		}else if(tolower(choice) == "wiki"){
			t<-create_column_doc(colname,values)
		}else{
			t<-construct_column_doc(colname,values)
		}
		if(nrow(t) > 0){
			if(i == 1){
				r<-t
			}else{
				if(nrow(t) >0){
					r<-rbind(r,t)
				}
			}
		}
	}
	filename<-paste0(fileroot,"-description.rds")
	if(file.exists(filename)){
		exist_df<-readRDS(filename)
		exist_df<-exist_df[!(exist_df$Original_Column %in% r$Original_Column),]
		exist_df<-rbind(exist_df,r)
		saveRDS(exist_df,filename)
	}else{
		saveRDS(r,filename)
	}
	gc()
	return(r)
}

constructName<-function(n=1,size=26){
# Description
# Generates temporary column name to be used when needed
# Arguments

	name <- c(1:n)
	for (i in 1:n){
		header<-sample(c(letters,LETTERS),1,replace=TRUE)
		body<-paste(sample(c(0:9,letters,LETTERS),size,replace=TRUE),collapse="")
		name[i]<-paste0(header,body)
	}
	return(name)
}

construct_column_doc<-function(colname,values){
# Description
# Generates google based description for the column instances
# Arguments
# colname - the name of the column with instances
# values - san array of the column instances
	SAMPLE_SIZE=1
	d<-data.frame()
	n<-length(values)
	for(i in 1:n){
		a<-tryCatch({
			discover_column_desc(values[i])
		},error=function(e){
			NULL
		})
		#a<-discover_column_desc(values[i])
		if(!is.null(a)){
			m<-min(length(a),SAMPLE_SIZE)
			a<-a[sample(length(a),m)]
			if(length(a) > 0){
				b<-as.data.frame(a)
				names(b)<-"X4"
				b$score=nrow(b)-row(b)+1
				if(nrow(b) > 1){
					b$score<-b$score/sum(row(b))
				}
				b$Original_Column<-colname
				b<-b[,c(3,1,2)]
				d<-rbind(d,b)
			}
		}
	}
	return(d)
}

create_column_doc<-function(colname,values){
# Description
# Generates wiki based description for the column instances
# Arguments
# colname - the name of the column with instances
# values - san array of the column instances
	library(WikidataR)
	d<-data.frame()
	n<-length(values)
	for(i in 1:n){
		a<-find_item(values[i])
		if(length(a) > 0){
			b<-data.frame(Reduce("rbind",lapply(a,function(x) cbind(x$title,x$label,x$pageid,ifelse(length(x$description)==0,NA,x$description)))))
			if(nrow(b) > 0){
				b$X4<-as.character(b$X4)
				b[is.na(b$X4),"X4"]<-as.character(b[is.na(b$X4),"X2"])
				b<-b[!(is.na(b$X4)),]
				if(nrow(b) > 0){
					if(nrow(d) > 0){
						d<-rbind(d,b[1,])
					}else{
						d<-b[1,]
					}
				}
			}
		}
	}
	if(nrow(d) > 0){
		d$X3<-as.numeric(as.character(d$X3))
		if(nrow(d) > 1){
			if(sd(d$X3) == 0){
				d$score<-abs(mean(d$X3))
			}else{
				d$score<-abs(mean(d$X3))/(abs(d$X3-mean(d$X3))/sd(d$X3)+1)
			}
		}else{
			d$score<-d$X3
		}
		d$score<-d$score/sum(d$score)
		d<-d[order(-d$score),c("X4","score")]
		d$Original_Column<-colname
		d<-d[,c("Original_Column","X4","score")]
	}
	return(d)
}

discover_column_desc<-function(searchTerm){
# Description
# Constructs google search string
# Arguments
# searchTerm - a given entry to use for search

	EXCLUDE<-"Advanced searchSearch Help Send feedback"
	EXCLUDE1<-"In order to show you the most relevant results"
	searchURL<-getSearchURL(searchTerm=searchTerm)
	doc.html <- getURL(searchURL, httpheader = c("User-Agent" = "R(2.10.0)"))
	doc.html<-htmlTreeParse(doc.html,useInternal = TRUE)
	doc.nodes <- getNodeSet(doc.html, "//h3[@class='r']//a")
	col.desc<-NULL
	if(length(doc.nodes) > 0){
		doc.desc<-unlist(xpathApply(doc.nodes[[1]], '//p', xmlValue))
		doc.desc<-str_trim(gsub('\\n', ' ', doc.desc),"both")
		n<-length(doc.desc)
		doc.desc<-doc.desc[!(doc.desc==EXCLUDE)]
		doc.desc<-doc.desc[!(substr(doc.desc,1,nchar(EXCLUDE1))==EXCLUDE1)]
		if(length(doc.desc) > 0){
			col.desc<-doc.desc[1]
		}
	}
	return(col.desc)
}

getSearchURL <- function(searchTerm, domain = '.com', quotes=TRUE) {
# Description
# Google search string helper
# Arguments
# searchTerm - a given entry to use for search
	searchTerm <- gsub(' ', '%20', searchTerm)
	if(quotes) search.term <- paste('%22', searchTerm, '%22', sep='')
		searchURL <- paste('http://www.google', domain, '/search?q=',searchTerm, sep='')
	return(searchURL)
}


#http: //papacochon.com/2015/10/18/Codage-12-r-visualization-3-bubble-bar-on-map/
library(raster)
library(ggplot2)
library(rgeos)
library(tmap)
setwd("C:/working/COVID19/map_outcome/")

shp < -shapefile("C:/working/COVID19/map_outcome/covid19_July_25.shp")

#shp < -shapefile("C:/working/COVID19/final_data_for_mapping/spatial_data/local_supply_chain_risk_score.shp")
#shp < -shapefile("C:/working/COVID19/map_outcome/zero_case_scenario.shp")
#shp < -shapefile("C:/working/COVID19/final_data_for_mapping/spatial_data/np_admin4_health_pop_all_indicators.shp")
admin0 < -shapefile("C:/working/COVID19/spatial_data/admin0.shp")
np_admin_3 < -shapefile("C:/working/COVID19/spatial_data/np_district.shp")
national_parks < -shapefile("C:/working/COVID19/spatial_data/national_parks.shp")

shp < -spTransform(shp, crs(admin0))
tmap_mode("plot")
#tmap_mode("view")

# === === === === === === == CTR === === === === ===
  #-- -- -- -- -- -- - perperson
max < -100
png("ctr_July_25.png", width = 6, height = 4, units = "in", res = 500);
tm_shape(shp) +
  tm_borders(col = "white", lwd = 0.1, lty = "solid", alpha = NA) +
  tm_fill(col = "CTR", palette = "-RdYlGn",
    style = "cont", breaks = c(0, 1 * max / 4, 2 * max / 4, 3 * max / 4, max), labels = c("Very Low", "Low", "Moderate", "High", "Very high"),
    title = "COVID-19 Transfer Risk", legend.show = TRUE, labels.size = 0.3) +
  tm_layout(legend.position = c(0.01, 0.01), legend.text.size = 0.5,
    legend.title.size = 0.6) +
  #tm_legend(position = c("right", "top"))
tm_compass(position = c(0.9, 0.8), size = 1, color.light = "grey90") +
  tm_credits("July  25", position = c(0.01, 0.24), size = 0.6) +
  tm_shape(national_parks) +
  tm_fill(col = '#006633') +
  tm_grid(n.x = 7, n.y = 5, lwd = 0.5, col = "grey90", labels.size = .4) +
  tm_scale_bar(position = c(0.2, 0.01), text.size = 0.5) +
  tm_shape(np_admin_3) +
  tm_borders(col = "grey50", lwd = 0.5, lty = "solid", alpha = 0.50) +
  tm_text("DISTRICT", size = 0.25, remove.overlap = TRUE)

dev.off()

#-- -- -- -- -- -- - total
png("trs_July_25_total_ppl.png", width = 6, height = 4, units = "in", res = 500);
max < -100
tm_shape(shp) +
  tm_borders(col = "white", lwd = 0.1, lty = "solid", alpha = NA) +
  tm_fill(col = "TRS_r_t", palette = "-RdYlGn",
    style = "cont", breaks = c(0, 1 * max / 4, 2 * max / 4, 3 * max / 4, max), labels = c("Very Low", "Low", "Moderate", "High", "Very high"),
    title = "Overall Risk Level", legend.show = TRUE, labels.size = 0.3) +
  tm_layout(legend.position = c(0.01, 0.01), legend.text.size = 0.5,
    legend.title.size = 0.6) +
  #tm_legend(position = c("right", "top"))
tm_compass(position = c(0.9, 0.8), size = 1, color.light = "grey90") +
  tm_credits("July 25", position = c(0.01, 0.24), size = 0.6) +
  tm_shape(national_parks) +
  tm_fill(col = '#006633') +
  tm_grid(n.x = 7, n.y = 5, lwd = 0.5, col = "grey90", labels.size = .4) +
  tm_scale_bar(position = c(0.2, 0.01), text.size = 0.5) +
  tm_shape(np_admin_3) +
  tm_borders(col = "grey50", lwd = 0.5, lty = "solid", alpha = 0.50) +
  tm_text("DISTRICT", size = 0.25, remove.overlap = TRUE)
dev.off()

# # # # # # # # # # # # # # # # # # # # # # # # # # # # # # #Base Map # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # #

max < -max(shp$CTR)
png("ctr_relative_risk.png", width = 6, height = 4, units = "in", res = 500);
tm_shape(shp) +
  tm_borders(col = "white", lwd = 0.1, lty = "solid", alpha = NA) +
  tm_fill(col = "CTR", palette = "-RdYlGn",
    style = "cont", breaks = c(0, 1 * max / 4, 2 * max / 4, 3 * max / 4, max), labels = c("Very Low", " ", " ", " ", "Very high"),
    title = "Relative Risk - CTR", legend.show = TRUE, labels.size = 0.3) +
  tm_layout(legend.position = c(0.01, 0.01), legend.text.size = 0.5,
    legend.title.size = 0.6) +
  #tm_legend(position = c("right", "top"))
tm_compass(position = c(0.9, 0.8), size = 1, color.light = "grey90") +
  tm_credits(" ", position = c(0.01, 0.24), size = 0.6) +
  tm_shape(national_parks) +
  tm_fill(col = '#006633') +
  tm_grid(n.x = 7, n.y = 5, lwd = 0.5, col = "grey90", labels.size = .4) +
  tm_scale_bar(position = c(0.2, 0.01), text.size = 0.5) +
  tm_shape(np_admin_3) +
  tm_borders(col = "grey50", lwd = 0.5, lty = "solid", alpha = 0.50) +
  tm_text("DISTRICT", size = 0.25, remove.overlap = TRUE)

dev.off()

#-- -- -- -- -- -- - total
png("trs_relative_risk.png", width = 6, height = 4, units = "in", res = 500);
max < -max(shp$TRS_r_t)
tm_shape(shp) +
  tm_borders(col = "white", lwd = 0.1, lty = "solid", alpha = NA) +
  tm_fill(col = "TRS_r_t", palette = "-RdYlGn",
    style = "cont", breaks = c(0, 1 * max / 4, 2 * max / 4, 3 * max / 4, max), labels = c("Very Low", " ", " ", " ", "Very high"),
    title = "Relative Risk - TRS", legend.show = TRUE, labels.size = 0.3) +
  tm_layout(legend.position = c(0.01, 0.01), legend.text.size = 0.5,
    legend.title.size = 0.6) +
  tm_compass(position = c(0.9, 0.8), size = 1, color.light = "grey90") +
  tm_credits(" ", position = c(0.01, 0.24), size = 0.6) +
  tm_shape(national_parks) +
  tm_fill(col = '#006633') +
  tm_grid(n.x = 7, n.y = 5, lwd = 0.5, col = "grey90", labels.size = .4) +
  tm_scale_bar(position = c(0.2, 0.01), text.size = 0.5) +
  tm_shape(np_admin_3) +
  tm_borders(col = "grey50", lwd = 0.5, lty = "solid", alpha = 0.50) +
  tm_text("DISTRICT", size = 0.25, remove.overlap = TRUE)
dev.off()

# # # # # # # # # # # # # # # # # # # # # # # # # # # # #Map
for regional importance - food security and supply chain
#setwd("C:/working/COVID19/map_outcome/")
#admin4_indicators < -shapefile("C:/working/COVID19/final_data_for_mapping/spatial_data/np_admin_3_4_all_indicators_may13_utm.shp")
#np_admin_3 < -shapefile("np_admin_3_ser.shp")
#road < -shapefile()
#shp < -admin4_indicators

max < -100
png("ser.png", width = 6, height = 4, units = "in", res = 500);
tm_shape(shp) +
  tm_borders(col = "grey50", lwd = 0.5, lty = "solid", alpha = 0.50) +
  tm_fill(col = "SERI_Rlt", palette = "-RdYlGn",
    style = "cont", breaks = c(0, 1 * max / 4, 2 * max / 4, 3 * max / 4, max), labels = c("Very Low", "Low", "Moderate", "High", "Very high"),
    title = "Socioeconomic Risk ", legend.show = TRUE, labels.size = 0.3) +
  tm_layout(legend.position = c(0.01, 0.01), legend.text.size = 0.5,
    legend.title.size = 0.6) +
  tm_compass(position = c(0.9, 0.8), size = 1, color.light = "grey90") +
  tm_grid(n.x = 7, n.y = 5, lwd = 0.5, col = "grey90", labels.size = .4) +
  tm_scale_bar(position = c(0.2, 0.01), text.size = 0.5) +
  tm_shape(np_admin_3) +
  tm_borders(col = "grey50", lwd = 0.1, lty = "solid", alpha = NA) +
  tm_text("DISTRICT", size = 0.25, remove.overlap = TRUE)
dev.off()

#-- -- -- -- -- - food important map-- -- -- -- -- -- -- -- --

shp < -regional_imp(admin4_indicators)
png("_food.png", width = 6, height = 4, units = "in", res = 500);
tm_shape(shp) +
  tm_borders(col = "white", lwd = 0.25, lty = "solid", alpha = 0.50) +
  tm_fill(col = "food", palette = "BuGn",
    style = "cont", breaks = c(0, 25, 50, 75, 100), labels = c("Low", " ", " ", " ", "High"),
    title = "Regional importance - Food ", legend.show = TRUE, labels.size = 0.3) +
  tm_layout(legend.position = c(0.01, 0.01), legend.text.size = 0.5,
    legend.title.size = 0.6) +
  tm_shape(national_parks) +
  tm_fill(col = '#ccebe4') +
  tm_compass(position = c(0.9, 0.8), size = 1, color.light = "grey90") +
  tm_grid(n.x = 7, n.y = 5, lwd = 0.5, col = "grey90", labels.size = .4) +
  tm_scale_bar(position = c(0.2, 0.01), text.size = 0.5) +
  tm_shape(np_admin_3) +
  tm_borders(col = "grey50", lwd = 0.1, lty = "solid", alpha = NA) +
  tm_text("DISTRICT", size = 0.25, remove.overlap = TRUE)
dev.off()

# # # # # # # # # # # # # # # # # Socioeconomic 00-- -- -- -- -- -- -- -- -- -- -- -- -- -- -

# # # # # # # # # # # # # # # # # Supply chain 00-- -- -- -- -- -- -- -- -- -- -- -- -- -- -
#road < -shapefile("C:/working/COVID19/spatial_data/NPL_rds/NPL_roads")
shp < -shapefile("C:/working/COVID19/final_data_for_mapping/spatial_data/local_supply_chain_risk_score.shp")
road_st < -shapefile("C:/working/COVID19/spatial_data/Strategic_Road_Network/Strategic Roads nepal.shp")
road_d < -shapefile("C:/working/COVID19/spatial_data/District_road/DRCN_All_Districts.shp")
max < -100
shp$Scrore < -as.numeric(shp$Scrore)
png("sci_b.png", width = 6, height = 4, units = "in", res = 500);
tm_shape(shp) +
  tm_borders(col = "grey50", lwd = 0.2, lty = "solid", alpha = 0.50) +
  tm_fill(col = "Scrore", palette = "BuGn",
    style = "cont", breaks = c(0, 1 * max / 4, 2 * max / 4, 3 * max / 4, max), labels = c("Very Low", " ", " ", " ", "Very high"),
    title = "Supply Chain Importance ", legend.show = TRUE, labels.size = 0.3) +
  tm_compass(position = c(0.9, 0.8), size = 1, color.light = "grey90") +
  tm_grid(n.x = 7, n.y = 5, lwd = 0.5, col = "grey90", labels.size = .4) +
  tm_scale_bar(position = c(0.2, 0.01), text.size = 0.5) +
  tm_shape(national_parks) +
  tm_fill(col = '#006633') +
  tm_shape(road_st) +
  tm_lines(col = "#7A3232", lwd = 0.6, lty = "solid", alpha = NA) +
  tm_add_legend(type = "line", col = "#7A3232", labels = "Major Road Network") +
  #tm_shape(road_d) +
  # tm_lines(col = "black", lwd = 0.2, lty = "solid", alpha = NA) +
  #tm_add_legend(type = "line", col = "black", labels = "Local Road Networks") +
  tm_shape(np_admin_3) +
  tm_borders(col = "grey50", lwd = 0.1, lty = "solid", alpha = NA) +
  tm_text("DISTRICT", size = 0.25, remove.overlap = TRUE) +
  tm_layout(legend.position = c(0.01, 0.01), legend.text.size = 0.5,
    legend.title.size = 0.6)
dev.off()

#PHR-- -- -- -- -- -- -- -- -- --

maxVal < -max(shp$r_PHR_p)
png("_phr_t_u.png", width = 6, height = 4, units = "in", res = 500);
tm_shape(shp) +
  tm_borders(col = "white", lwd = 0.1, lty = "solid", alpha = NA) +
  tm_fill(col = "r_PHR_t", palette = "-RdYlGn",
    style = "cont", breaks = c(0, 1 * (maxVal / 6), 2 * (maxVal / 6), 3 * (maxVal / 6), 4 * maxVal / 6), labels = c("Very Low", "Low", "Moderate", "High", "Very high"),
    title = "Public Health Risk  ", legend.show = TRUE, labels.size = 0.3) +
  tm_layout(legend.position = c(0.01, 0.01), legend.text.size = 0.5,
    legend.title.size = 0.6) +
  #tm_legend(position = c("right", "top"))
tm_compass(position = c(0.9, 0.8), size = 1, color.light = "grey90") +
  tm_shape(national_parks) +
  tm_fill(col = '#006633') +
  tm_grid(n.x = 7, n.y = 5, lwd = 0.5, col = "grey90", labels.size = .4) +
  tm_scale_bar(position = c(0.2, 0.01), text.size = 0.5) +
  tm_shape(np_admin_3) +
  tm_borders(col = "grey50", lwd = 0.5, lty = "solid", alpha = 0.50) +
  tm_text("DISTRICT", size = 0.25, remove.overlap = TRUE)
dev.off()

#UHC-- -- -- -- -- -- -- -- -- --
#shp < -admin4_indicators
#shp$r_UHC_p
#shp$r_UHC
maxVal < -max(shp$r_UHC)
png("_uhc_t.png", width = 6, height = 4, units = "in", res = 500);
tm_shape(shp) +
  tm_borders(col = "white", lwd = 0.1, lty = "solid", alpha = NA) +
  tm_fill(col = "r_UHC", palette = "-RdYlGn",
    style = "cont", breaks = c(0, 1 * (maxVal / 4), 2 * (maxVal / 4), 3 * (maxVal / 4), 4 * maxVal / 4), labels = c("Very Low", "Low", "Moderate", "High", "Very high"),
    title = "Health Condition ", legend.show = TRUE, labels.size = 0.3) +
  tm_layout(legend.position = c(0.01, 0.01), legend.text.size = 0.5,
    legend.title.size = 0.6) +
  #tm_legend(position = c("right", "top"))
tm_compass(position = c(0.9, 0.8), size = 1, color.light = "grey90") +
  tm_shape(national_parks) +
  tm_fill(col = '#006633') +
  tm_grid(n.x = 7, n.y = 5, lwd = 0.5, col = "grey90", labels.size = .4) +
  tm_scale_bar(position = c(0.2, 0.01), text.size = 0.5) +
  tm_shape(np_admin_3) +
  tm_borders(col = "grey50", lwd = 0.5, lty = "solid", alpha = 0.50) +
  tm_text("DISTRICT", size = 0.25, remove.overlap = TRUE)
dev.off()

max < -100

#Regional importance
png("regioinal_importance.png", width = 6, height = 4, units = "in", res = 500);
tm_shape(shp) +
  tm_borders(col = "white", lwd = 0.1, lty = "solid", alpha = NA) +
  tm_fill(col = "r_imp", palette = "-RdYlGn",
    style = "cont", breaks = c(0, 1 * (maxVal / 5), 2 * (maxVal / 5), 3 * (maxVal / 5), 4 * maxVal / 5), labels = c("Very Low", "Low", "Moderate", "High", "Very high"),
    title = "Regional", legend.show = TRUE, labels.size = 0.3) +
  tm_layout(legend.position = c(0.01, 0.01), legend.text.size = 0.5,
    legend.title.size = 0.6) +
  #tm_legend(position = c("right", "top"))
tm_compass(position = c(0.9, 0.8), size = 1, color.light = "grey90") +
  tm_grid(n.x = 7, n.y = 5, lwd = 0.5, col = "grey90", labels.size = .4) +
  tm_scale_bar(position = c(0.2, 0.01), text.size = 0.5) +
  tm_shape(np_admin_3) +
  tm_borders(col = "grey50", lwd = 0.5, lty = "solid", alpha = 0.50) +
  tm_text("DISTRICT", size = 0.3)
dev.off()

#HPI
png("hpi.png", width = 4, height = 3, units = "in", res = 500);
tm_shape(shp) +
  tm_borders(col = "white", lwd = 0.5, lty = "solid", alpha = NA) +
  tm_polygons(col = "Max_HPI", title = "HPI", palette = "-RdYlGn",
    style = "cont", breaks = c(0, 20, 40, 60, 80), labels = c("Very Low", "Low", "Moderate", "High", "Very high")) +
  tm_layout(legend.position = c(0.01, 0.01), legend.text.size = 1, legend.height = 0.5) +
  #tm_legend(position = c("right", "top"))
tm_compass(position = c(0.9, 0.8), size = 1, color.light = "grey90") +
  tm_grid(n.x = 7, n.y = 5, lwd = 0.5, col = "grey90") +
  tm_scale_bar(position = c(0.2, 0.01), text.size = 0.5) +
  tm_shape(admin0) +
  tm_borders()
dev.off()

#Hypertensi
png("Hypertensi.png", width = 4, height = 3, units = "in", res = 500);
tm_shape(shp) +
  tm_borders(col = "white", lwd = 0.5, lty = "solid", alpha = NA) +
  tm_polygons(col = "Hypertensi", palette = "-RdYlGn",
    style = "cont") +
  tm_layout(legend.position = c(0.01, 0.01), legend.text.size = 1, legend.height = 0.4) +
  #tm_legend(position = c("right", "top"))
tm_compass(position = c(0.9, 0.8), size = 1, color.light = "grey90") +
  tm_grid(n.x = 7, n.y = 5, lwd = 0.5, col = "grey90") +
  tm_scale_bar(position = c(0.2, 0.01), text.size = 0.5) +
  tm_shape(admin0) +
  tm_borders()
dev.off()

#shp$UHC
#UHC
png("UHC.png", width = 4, height = 3, units = "in", res = 500);
tm_shape(shp) +
  tm_borders(col = "white", lwd = 0.5, lty = "solid", alpha = NA) +
  tm_polygons(col = "UHC", palette = "-RdYlGn",
    style = "cont") +
  tm_layout(legend.position = c(0.01, 0.01), legend.text.size = 1, legend.height = 0.4) +
  #tm_legend(position = c("right", "top"))
tm_compass(position = c(0.9, 0.8), size = 1, color.light = "grey90") +
  tm_grid(n.x = 7, n.y = 5, lwd = 0.5, col = "grey90") +
  tm_scale_bar(position = c(0.2, 0.01), text.size = 0.5) +
  tm_shape(admin0) +
  tm_borders()
dev.off()

#shp$PHR
#PHR
png("PHR.png", width = 4, height = 3, units = "in", res = 500);
tm_shape(shp) +
  tm_borders(col = "white", lwd = 0.5, lty = "solid", alpha = NA) +
  tm_polygons(col = "PHR", palette = "-RdYlGn",
    style = "cont") +
  tm_layout(legend.position = c(0.01, 0.01), legend.text.size = 1, legend.height = 0.4) +
  #tm_legend(position = c("right", "top"))
tm_compass(position = c(0.9, 0.8), size = 1, color.light = "grey90") +
  tm_grid(n.x = 7, n.y = 5, lwd = 0.5, col = "grey90") +
  tm_scale_bar(position = c(0.2, 0.01), text.size = 0.5) +
  tm_shape(admin0) +
  tm_borders()
dev.off()


#
# Repeat the time-based extraction but instead of post by posts,
# local-dynamic by local-dynamic
# The (initial) motivation is to avoid etracting overlapping neighbourhoods
# from a same user
#################################################
source('R/count_motifs_by_segment.r')
###################################################
# Load data
###################################################
load('./R_objects/dfposts_podemos.Rda')
df.posts <- df.posts
df.posts$date <- as.numeric(df.posts$date)
df.posts <- data.frame(df.posts) %>% arrange(date)
df.posts <- df.posts[1:75000,] # Paper
df.threads <- plyr::count(df.posts, "thread")
df.users <- plyr::count(df.posts, 'user')
names(df.threads)[2] <- "length"
names(df.users)[2] <- "posts"
df.posts$forum <- 'podemos'

#########################################################
# Compute neighborhoods by user-dynamic_segment
#########################################################
# Only long threads
#df.threads <- filter(df.threads, length>10)

chunks <- split(df.threads$thread, ceiling(seq_along(df.threads$thread)/135))
length(chunks)

res.seq <- count_motifs_by_usersegment(as.vector(unlist(chunks)),
                                      database='reddit')


##==========================================
## Name Convention in the rbms package
##
##      FUNCTION: ts_snake_function()
##      ARGUMENT: CamelNotation
##      OBJECT: object_snake_name
##      VARIABLE NAME: UPPER_CASE
##
##      Date:   02.01.2018
##
##      index_modelling: functions for abundance index model
##
##==========================================

#' fit_gam
#' fit a Generalized Additive Model to butterfly count data to extract the annual flight curve.
#' @param dataset_y data.table with filtered butterfly counts for species x over year y over all sites.
#' @param NbrSample integer inherited from \link{flight_curve}, default=100.
#' @param GamFamily string inherited from \link{flight_curve}, default='poisson', but can be 'nb' or 'quasipoisson'.
#' @param MaxTrial integer inherited from \link{flight_curve}, default=3.
#' @param SpeedGam Logical to use the \link[mgcv]{bam} method instead of the \link[mgcv]{gam} method.
#' @param OptiGam Logical to set use bam when data are larger than 100 and gam for smaller dataset
#' @param ... additional parameters passed to gam or bam function from the \link[mgcv]{gam} package.
#' @return A list with three objects, i) **f_curve**: a data.table with the flight curve \code{f_curve} with expected relative abudance, normalize to sum to one over a full season,
#'         ii) **f_model**: the resulting gam model \code{f_model} fitted on the count data and iii) **f_data**: a data.table with the data used to fit the GAM model.
#' @keywords gam
#' @seealso \link{flight_curve}, \link[mgcv]{gam}, \link[mgcv]{bam}
#' @author Reto Schmucki - \email{reto.schmucki@@mail.mcgill.ca}
#' @import data.table
#' @export fit_gam
#'

fit_gam <- function(dataset_y, NbrSample = NbrSample, GamFamily = GamFamily, MaxTrial = MaxTrial,
                    SpeedGam = TRUE, OptiGam = TRUE, ...){

        check_package('data.table')

        tr <- 1
        gam_obj_site <- c()

        while((tr == 1 | class(gam_obj_site)[1] == "try-error") & tr <= MaxTrial){

            if (dataset_y[, uniqueN(SITE_ID)] > NbrSample) {
                sp_data_all <- data.table::copy(dataset_y[SITE_ID %in% sample(unique(dataset_y[, SITE_ID]), NbrSample, replace = FALSE), ])
            } else {
                sp_data_all <- data.table::copy(dataset_y)
            }

            if(isTRUE(OptiGam)){
                if(sp_data_all[, uniqueN(SITE_ID)] < 100){
                    SpeedGam <- FALSE
                }
            }

            gamMethod <-'gam()'
            if(isTRUE(SpeedGam)){
                gamMethod <- 'SpeedGAM [bam()]'
            }

            print(paste("Fitting the RegionalGAM for species", as.character(sp_data_all$SPECIES[1]), "and year", sp_data_all$M_YEAR[1], "with",
                        sp_data_all[, uniqueN(SITE_ID)], "sites, using", gamMethod, ":", Sys.time(), "-> trial", tr))

            if(isTRUE(SpeedGam)){
                if(length(sp_data_all[, unique(SITE_ID)]) > 1){
                    gam_obj_site <- try(mgcv::bam(COUNT ~ s(trimDAYNO, bs = "cr") + as.factor(SITE_ID), data=sp_data_all, family=GamFamily, ...), silent = TRUE)
                } else {
                    gam_obj_site <- try(mgcv::bam(COUNT ~ s(trimDAYNO, bs = "cr"), data=sp_data_all, family=GamFamily, ...), silent = TRUE)
                }
            } else {
                if(length(sp_data_all[, unique(SITE_ID)]) > 1){
                    gam_obj_site <- try(mgcv::gam(COUNT ~ s(trimDAYNO, bs = "cr") + as.factor(SITE_ID), data=sp_data_all, family=GamFamily, ...), silent = TRUE)
                } else {
                    gam_obj_site <- try(mgcv::gam(COUNT ~ s(trimDAYNO, bs = "cr"), data=sp_data_all, family=GamFamily, ...), silent = TRUE)
                }
            }

            tr <- tr + 1

        }

        if (class(gam_obj_site)[1] == "try-error") {
            print(paste("Error in fitting the RegionalGAM for species", as.character(sp_data_all$SPECIES[1]), "and year", sp_data_all$M_YEAR[1],
                    "; Model did not converge after", tr, "trials"))
            sp_data_all[, c("FITTED", "NM") := .(NA, NA)]
        } else {
            sp_data_all[, FITTED := mgcv::predict.gam(gam_obj_site, newdata = sp_data_all[, c("trimDAYNO", "SITE_ID")], type = "response")]
            sp_data_all[M_SEASON == 0L, FITTED := 0]

            if(sum(is.infinite(sp_data_all[, FITTED])) > 0){
                sp_data_all[, c("FITTED", "NM") := .(NA, NA)]
            } else {
                sp_data_all[, SITE_SUM := sum(FITTED), by = SITE_ID]
                sp_data_all[, NM := round(FITTED / SITE_SUM, 5)]
            }
        }

        f_curve <- sp_data_all[, .(SPECIES, DATE, WEEK, WEEK_DAY, DAY_SINCE, M_YEAR, M_SEASON, trimDAYNO,NM)]
        data.table::setkey(f_curve)
        f_curve <- unique(f_curve)

        f_curve_mod <- list(f_curve = f_curve, f_model = gam_obj_site, f_data = sp_data_all)

    return(f_curve_mod)
}

#' flight_curve
#' Compute the annual flight curve from butterfly count data collated across multiple sites.
#' @param ts_season_count data.table with complete time series of count and season information returned by \link{ts_monit_count_site}
#' @param NbrSample integer setting the maximum number of site to use to compute the flight curve, default=100.
#' @param MinVisit integer setting the minimum number of visit required for a site to included in the computation, default=3.
#' @param MinOccur integer setting the minimum number of positive records (e.g. >= 1) observed over the year in a site default=2.
#' @param MinNbrSite integer setting the minimum number of site required to compute the flight curve, default=1.
#' @param MaxTrial integer setting the maximum number of trial to reach convergence of the model, default=3.
#' @param FcMethod string defining the method to be used for computation of the flight curve, default='regionalGAM' (no other method is available yet).
#' @param GamFamily string setting the distribution of the error term in the GAM, default='poisson', but can be 'nb' or 'quasipoisson'.
#' @param CompltSeason Logical to restrict computation of flight curve for years where the complete season has been sampled, default=TRUE.
#' @param SelectYear integer to select a specific year to compute the flight curve, default=NULL.
#' @param SpeedGam Logical to use the \link[mgcv]{bam} method instead of the \link[mgcv]{gam} method.
#' @param OptiGam Logical to set use bam when data are larger than 100 and gam for smaller dataset.
#' @param KeepModel Logical to keep model output in a list object named \code{flight_curve_model}.
#' @param KeepModelData Logical to keep the data used for the GAM.
#' @param ... additional parameters passed to gam or bam function from the \link[mgcv]{gam} package.
#' @return A list with three objects, i) **pheno**: a vector with annual flight curves \code{f_pheno} with expected relative abudance, normalize to sum to one over a full season,
#'         ii) **model**: a list of the resulting gam models \code{f_model} fitted on the count data for each year and iii) **data**: a data.table with the data used to fit the GAM model.
#' @keywords gam, flight curve
#' @seealso \link{fit_gam}
#' @seealso \link[mgcv]{gam}
#' @seealso \link[mgcv]{bam}
#' @author Reto Schmucki - \email{reto.schmucki@@mail.mcgill.ca}
#' @import data.table
#' @export flight_curve
#'

flight_curve <- function(ts_season_count, NbrSample = 100, MinVisit = 3, MinOccur = 2, MinNbrSite = 1, MaxTrial = 3, FcMethod = 'regionalGAM',
                            GamFamily = 'poisson', CompltSeason = TRUE, SelectYear = NULL, SpeedGam = TRUE, OptiGam = TRUE, KeepModel = TRUE, KeepModelData = TRUE, ...) {

        check_package('data.table')

        names(ts_season_count) <- toupper(names(ts_season_count))
        check_names(ts_season_count,c("COMPLT_SEASON", "M_YEAR", "SITE_ID", "SPECIES", "DATE", "WEEK", "WEEK_DAY", "DAY_SINCE", "M_SEASON", "COUNT", "ANCHOR"))

        if(isTRUE(CompltSeason)){
            ts_season_count <- ts_season_count[COMPLT_SEASON == 1]
        }

        # if(exists("f_pheno")){
        #     rm(f_pheno)
        # }

        if(is.null(SelectYear)){
            year_series <- ts_season_count[, unique(as.integer(M_YEAR))]
        } else {
            year_series <- ts_season_count[M_YEAR %in% SelectYear, unique(as.integer(M_YEAR))]
        }

        f_pheno <- data.table::data.table()
        f_data  <- data.table::data.table()
        f_model <- list()

        for (y in year_series) {

            dataset_y <- ts_season_count[as.integer(M_YEAR) == y, .(SPECIES, SITE_ID, DATE, WEEK, WEEK_DAY, DAY_SINCE, M_YEAR, M_SEASON, COUNT, ANCHOR)]
            dataset_y[, trimDAYNO := DAY_SINCE - min(DAY_SINCE) + 1]

            ## filter for site with at least x visits and x occurrences
            visit_occ_site <- merge(dataset_y[!is.na(COUNT) & ANCHOR == 0L, .N, by=SITE_ID], dataset_y[!is.na(COUNT) & ANCHOR == 0L & COUNT > 0, .N, by=SITE_ID], by="SITE_ID", all=TRUE)
            dataset_y <- data.table::copy(dataset_y[SITE_ID %in% visit_occ_site[N.x >= MinVisit & N.y >= MinOccur, SITE_ID],])

            if(dataset_y[,uniqueN(SITE_ID)] < MinNbrSite){
                dataset_y <- ts_season_count[as.integer(M_YEAR) == y, .(SPECIES, DATE, WEEK, WEEK_DAY, DAY_SINCE, M_YEAR, M_SEASON)]
                dataset_y[, trimDAYNO := DAY_SINCE - min(DAY_SINCE) + 1]
                f_curve <- dataset_y[, NM := NA]
                data.table::setkey(f_curve, SPECIES, DAY_SINCE)
                f_curve <- unique(f_curve)
                f_curve_mod <- list(f_curve=f_curve, f_model=NA)
                print(paste("You have not enough sites with observations for estimating the flight curve for species", as.character(dataset_y$SPECIES[1]), "in", dataset_y$M_YEAR[1]))
            } else {
                if(FcMethod=='regionalGAM'){
                    f_curve_mod <- fit_gam(dataset_y, NbrSample = NbrSample, GamFamily = GamFamily, MaxTrial = MaxTrial,
                                            SpeedGam = SpeedGam, OptiGam = OptiGam, KeepModel = KeepModel, ...)
                } else {
                    print("ONLY the regionalGAM method is available so far!")
                }
            }

            f_pheno <- rbind(f_pheno, f_curve_mod$f_curve)

            if(isTRUE(KeepModel)){
              f_model_2 <- list(f_curve_mod$f_model)
              names(f_model_2) <- paste0('FlightModel_', gsub(' ', '_', as.character(dataset_y$SPECIES[1])), '_', dataset_y$M_YEAR[1])
              f_model <- c(f_model, f_model_2)
            }

            if(isTRUE(KeepModelData)){
              f_data <- rbind(f_data, data.table::data.table(f_curve_mod$f_data))
            }

        }

    if(!isTRUE(KeepModelData) & !isTRUE(KeepModel)){
          result_fc <- list(pheno = f_pheno)
        }

    if(!isTRUE(KeepModelData) & isTRUE(KeepModel)){
          result_fc <- list(pheno = f_pheno, model = f_model)
        }

    if(isTRUE(KeepModelData) & isTRUE(KeepModel)){
          result_fc <- list(pheno = f_pheno, model = f_model, data = f_data)
        }

    return(result_fc)
}

#' check_pheno
#' Check for the flight curve of a specific year and if missing, impute the nearest available within a span of 5 years.Function used in \link{impute_count}.
#' @param sp_count_flight_y data.table with the flight curve, relative abundance (NM), for a specific year.
#' @param sp_count_flight data.table with the flight curves, relative abundance (NM), for all years available for search as returned by \link{flight_curve}.
#' @return A data.table with time series of the expected relative abundance of butterfly count per day (NM) for the year or the nearest year where
#'         phenology is available.
#' @keywords flight curve
#' @seealso \link{impute_count}, \link{flight_curve}
#' @author Reto Schmucki - \email{reto.schmucki@@mail.mcgill.ca}
#' @import data.table
#' @export check_pheno
#'

check_pheno <- function(sp_count_flight_y, sp_count_flight){

        if(sp_count_flight_y[is.na(NM), .N] > 0){
            y_ <- unique(sp_count_flight_y[, as.integer(M_YEAR)])
            tr <- 1
            z <- rep(1:5, rep(2, 5)) * c(-1, 1)
            search_op <- unique(sp_count_flight[, as.integer(M_YEAR)])
            valid_y <- c(y_ + z)[c(y_ + z) > min(search_op) & c(y_ + z) < max(search_op)]
            alt_flight <- unique(sp_count_flight[as.integer(M_YEAR) == y_, .(M_YEAR, trimDAYNO, NM)])

            while(alt_flight[is.na(NM), .N] > 0 & tr <= length(valid_y)){
                alt_flight <- unique(sp_count_flight[as.integer(M_YEAR) == valid_y[tr], .(M_YEAR, trimDAYNO, NM)])
                tr <- tr + 1
            }

            if(alt_flight[is.na(NM), .N] > 0){
                print(paste("No reliable flight curve available within a 5 year horizon of", sp_count_flight_y[1, M_YEAR, ]))

            } else {
                warning(paste("We used the flight curve of", alt_flight[1, M_YEAR], "to compute abundance indices for year", sp_count_flight_y[1, M_YEAR, ]))
                sp_count_flight_y[, trimDAYNO := DAY_SINCE - min(DAY_SINCE) + 1]
                data.table::setnames(alt_flight, 'NM', 'NMnew')
                alt_flight[, M_YEAR := NULL]
                data.table::setkey(sp_count_flight_y, trimDAYNO)
                data.table::setkey(alt_flight, trimDAYNO)
                sp_count_flight_y <- merge(sp_count_flight_y, alt_flight, by='trimDAYNO', all.x=TRUE)
                sp_count_flight_y[, NM := NMnew][, NMnew := NULL]
            }
        }

        return(sp_count_flight_y)

    }

#' fit_glm
#' Fit a Generalized Linear Model (GLM) to predict daily count per site, using the regional flight curve as offset. Function used in \link{impute_count}.
#' @param sp_count_flight_y data.table with time series of the expected relative abundance of butterfly count per day (NM) for the year of interest,
#'        or the nearest available.
#' @param non_zero vector of sites with non-zero value to be included in the model (see detail)
#' @param FamilyGlm string for the distribution to be used for the error term in the GLM, inherited from \link{impute_count}, default='quasipoisson'.
#' @return A a list of objects, i) **sp_count_flight_y**: data.table with data and expected relative abundance of butterfly count per day (NM) for the year or the nearest year where
#'         a fligh curve (phenology) is available \code{sp_count_flight_y} and ii) **glm_obj_site**:a glm object for the model \code{glm_obj_site}.
#' @details GLM model is only fitted for site with observations, non-zero, as the abundance for sites where count are only zeros is expected to be null
#' @keywords flight curve
#' @seealso \link{impute_count}, \link{flight_curve}
#' @author Reto Schmucki - \email{reto.schmucki@@mail.mcgill.ca}
#' @import data.table
#' @export fit_glm
#'

fit_glm <- function(sp_count_flight_y, non_zero, FamilyGlm){

            if(sp_count_flight_y[SITE_ID %in% non_zero,uniqueN(SITE_ID)] > 1){
                glm_obj_site <- try(glm(COUNT ~ factor(SITE_ID) + offset(log(NM)) -1, data = sp_count_flight_y[SITE_ID %in% non_zero, ],
                family = FamilyGlm, control = list(maxit = 100)), silent = TRUE)
            } else {
                glm_obj_site <- try(glm(COUNT ~ offset(log(NM)) -1, data = sp_count_flight_y[SITE_ID %in% non_zero, ],
                family = FamilyGlm, control = list(maxit = 100)), silent = TRUE)
            }

            if (class(glm_obj_site)[1] == "try-error") {

                sp_count_flight_y[SITE_ID %in% non_zero, c("FITTED","COUNT_IMPUTED") := .(NA, NA)]

                print(paste("Computation of abundance indices for year",sp_count_flight_y[1, M_YEAR,],
                            "failed with the RegionalGAM, verify the data you provided for that year"))
                # next()

            } else {
                sp_count_flight_y[SITE_ID %in% non_zero, FITTED := predict.glm(glm_obj_site, newdata = sp_count_flight_y[SITE_ID %in% non_zero, ], type = "response")]
            }

            sp_count_flight_mod_y <- list(sp_count_flight_y = sp_count_flight_y, glm_obj_site = glm_obj_site)

        return(sp_count_flight_mod_y)
    }

#' fit_glm.nb
#' Fit a Generalized Linear Model (GLM) to predict daily count per site, using the regional flight curve as offset and the negative binomial error distribution
#' as implemented in the package link[MASS]{glm.nb}. Function used in \link{impute_count}.
#' @param sp_count_flight_y data.table with time series of the expected relative abundance of butterfly count per day (NM) for the year of interest,
#'        or the nearest available.
#' @param non_zero vector of sites with non-zero value to be included in the model (see detail)
#' @return A a list of two objects, i) **sp_count_flight_y**: data.table with data and expected relative abundance of butterfly count per day (NM) for the year or the nearest year where
#'         a fligh curve (phenology) is available \code{sp_count_flight_y} and ii) **glm_obj_site**: a glm object for the model \code{glm_obj_site}.
#' @details GLM model is only fitted for site with observations, non-zero, as the abundance for sites where count are only zeros is expected to be null
#' @keywords flight curve
#' @seealso \link{impute_count}, \link{flight_curve}
#' @author Reto Schmucki - \email{reto.schmucki@@mail.mcgill.ca}
#' @import data.table
#' @export fit_glm.nb
#'

fit_glm.nb <- function(sp_count_flight_y, non_zero){

            if(sp_count_flight_y[SITE_ID %in% non_zero,uniqueN(SITE_ID)] > 1){
                glm_obj_site <- try(MASS::glm.nb(COUNT ~ factor(SITE_ID) + offset(NM), data=sp_count_flight_y[SITE_ID %in% non_zero, ]), silent = TRUE)
            } else {
                glm_obj_site <- try(MASS::glm.nb(COUNT ~ offset(NM) -1, data = sp_count_flight_y[SITE_ID %in% non_zero, ]), silent = TRUE)
            }

            if (class(glm_obj_site)[1] == "try-error") {
                sp_count_flight_y[SITE_ID %in% non_zero, c("FITTED", "COUNT_IMPUTED") := .(NA,NA)]

                print(paste("Computation of abundance indices for year", sp_count_flight_y[1, M_YEAR, ],
                "failed with the RegionalGAM, verify the data you provided for that year"))

                # next()

            } else {
                sp_count_flight_y[SITE_ID %in% non_zero, FITTED := predict(glm_obj_site, newdata = sp_count_flight_y[SITE_ID %in% non_zero, ], type = "response")]
            }

            sp_count_flight_mod_y <- list(sp_count_flight_y = sp_count_flight_y, glm_obj_site = glm_obj_site)

        return(sp_count_flight_mod_y)
    }

#' impute_count
#' Fit a Generalized Linear Model (GLM) to predict daily count per site, using the regional flight curve as offset.
#' @param ts_season_count data.table with time series of counts for a specific species across all sites as returned by \link{ts_monit_count_site}.
#' @param ts_flight_curve data.table with the flight curves, relative abundance (NM), for a specific species as returned by \link{flight_curve}.
#' @param FamilyGlm string for the distribution to be used for the error term in the GLM, default='quasipoisson'.
#' @param CompltSeason logical to define if only years where a complete season is available should be modelled.
#' @param SelectYear vector of specific years of interest, can be a single value (e.g. 2015).
#' @param NearPheno Logical if flight curve from neirhest year should be used, if available within 5 years, default=TRUE
#' @param KeepModel Logical to keep model output in a list object named \code{imp_glm_model}
#' @return A a list of one or two objects, i) **impute_count**: data.table with observed and expected butterfly counts per day imputed based on the flight curve of the year or the nearest year where
#'         a phenology is available \code{sp_ts_season_count} and ii) **model**: a glm object for the GLM model \code{glm_model}.
#' @details GLM model is only fitted for site with observations, non-zero, as the abundance for sites where count are only zeros is expected to be null.
#' @keywords flight curve
#' @seealso \link{fit_glm}, \link{fit_glm.nb}, \link{flight_curve}
#' @author Reto Schmucki - \email{reto.schmucki@@mail.mcgill.ca}
#' @import data.table
#' @export impute_count
#'

impute_count <- function(ts_season_count, ts_flight_curve, FamilyGlm = quasipoisson(), CompltSeason = TRUE,
                                    SelectYear = NULL, KeepModel = TRUE, NearPheno = TRUE) {

        if(ts_season_count$SPECIES[1] != ts_flight_curve$SPECIES[1]){
            stop('Species in count data and flight curve must be the same!')
        }

        if(FamilyGlm[1]=='nb'){
            stop('Negative binomial distribution for GLM is not resolved, please use quasipoisson distribution instead')
        }

        check_package('data.table')

        if(isTRUE(CompltSeason)){
            ts_season_count <- ts_season_count[COMPLT_SEASON==1]
        }

        sp_ts_season_count <- data.table::copy(ts_season_count)
        data.table::setkey(sp_ts_season_count, DATE)
        data.table::setkey(ts_flight_curve, DATE)
        sp_count_flight <- merge(sp_ts_season_count, ts_flight_curve[, .(DATE, trimDAYNO, NM)], all.x=TRUE)
        data.table::setkey(sp_count_flight, M_YEAR, DATE, SITE_ID)

        glmMet <- "glm()"

        if( FamilyGlm[1]=='nb'){
            glmMet <- "glm.nb()"
        }

        if(is.null(SelectYear)){
            year_series <- ts_season_count[, unique(as.integer(M_YEAR))]
        } else {
            year_series <- ts_season_count[M_YEAR %in% SelectYear, unique(as.integer(M_YEAR))]
        }

        i_glm_model <- list()

        for(y in year_series){

            sp_count_flight_y <-  data.table::copy(sp_count_flight[as.integer(M_YEAR) == y, ])

            if(isTRUE(NearPheno)){
                sp_count_flight_y <- check_pheno(sp_count_flight_y, sp_count_flight)
            }

            if(sp_count_flight_y[is.na(NM) & trimDAYNO != 366, .N] > 0){
                print(paste("No glm model will be fitted for", sp_count_flight_y[1, M_YEAR]))
            } else {
                print(paste("Computing abundance indices for", sp_count_flight_y[1, SPECIES], "in", sp_count_flight_y[1, M_YEAR], "across",
                        sp_count_flight_y[,uniqueN(SITE_ID)], "sites, using", glmMet, ":", Sys.time()))
            }

            sp_count_flight_y[M_SEASON == 0L, COUNT := NA]
            sp_count_flight_y[M_SEASON != 0L & NM == 0, NM := 0.000001]
            non_zero <- sp_count_flight_y[, sum(COUNT, na.rm=TRUE), by=(SITE_ID)] [V1 > 0, SITE_ID]
            zero <- sp_count_flight_y[, sum(COUNT, na.rm=TRUE), by=(SITE_ID)] [V1 == 0, SITE_ID]

            if(length(non_zero) >= 1 & sp_count_flight_y[is.na(NM) & trimDAYNO != 366, .N] == 0){
                if(FamilyGlm[1] == 'nb'){
                    sp_count_flight_l <- fit_glm.nb(sp_count_flight_y, non_zero)
                } else {
                    sp_count_flight_l <- fit_glm(sp_count_flight_y, non_zero, FamilyGlm)
                }
            } else {
               sp_count_flight_l <- list(sp_count_flight_y = sp_count_flight_y,
                                    glm_obj_site = paste('No glm fitted for', sp_count_flight_y[1, M_YEAR]))
            }

            sp_count_flight_y <- sp_count_flight_l$sp_count_flight_y

            sp_count_flight_y[SITE_ID %in% zero, FITTED := 0]
            sp_count_flight_y[is.na(COUNT), COUNT_IMPUTED := FITTED][!is.na(COUNT), COUNT_IMPUTED := as.numeric(COUNT)] [M_SEASON == 0L, COUNT_IMPUTED := 0]

            data.table::setkey(sp_ts_season_count, SITE_ID, DAY_SINCE)
            data.table::setkey(sp_count_flight_y, SITE_ID, DAY_SINCE)

            if("FITTED" %in% names(sp_ts_season_count)){
                sp_ts_season_count[sp_count_flight_y, ':=' (trimDAYNO=i.trimDAYNO, NM=i.NM, FITTED=i.FITTED, COUNT_IMPUTED=i.COUNT_IMPUTED)]
            } else {
                sp_ts_season_count <- merge(sp_ts_season_count, sp_count_flight_y[, .(DAY_SINCE, SITE_ID, trimDAYNO, NM, FITTED, COUNT_IMPUTED)], all.x = TRUE)
            }

            if(isTRUE(KeepModel)){
                    glm_model <- list(sp_count_flight_l$glm_obj_site)
                    names(glm_model) <- paste0('glm_mod_', gsub(' ', '_', sp_count_flight_y[1, SPECIES]), '_', sp_count_flight_y[1, M_YEAR])
                    i_glm_model <- c(i_glm_model, glm_model)
                }
            }

        if(!is.null(SelectYear)){
            sp_ts_season_count <- sp_ts_season_count[M_YEAR %in% SelectYear, ]
        } else {
            sp_ts_season_count <- sp_ts_season_count
        }

        if(isTRUE(KeepModel)){
          return(list(impute_count = sp_ts_season_count, model = i_glm_model))
        } else {
          return(list(impute_count = sp_ts_season_count))
        }
}

#' butterfly_day
#' count cumulative butterfly count observed over one monitoring season.
#' @param sp_ts_season_count list of objects, including a data.table with observed and expected butterfly counts per day imputed for each sites based by \link{impute_count}.
#' @param WeekCount logical defining if butterfly day should be counted by week (default), using the 4th day of the week, or as a total of predicted daily counts.
#' @return data.table with total butterfly day observed per species, year, and site.
#' @keywords butterfly count
#' @seealso \link{impute_count}, \link{flight_curve}
#' @author Reto Schmucki - \email{reto.schmucki@@mail.mcgill.ca}
#' @import data.table
#' @export butterfly_day
#'

butterfly_day <- function(sp_ts_season_count, WeekCount = TRUE){
            if (WeekCount == TRUE){
                b_day <- site_year_sp_count$impute_count[COMPLT_SEASON == 1 & M_SEASON != 0 & WEEK_DAY == 4, FITTED, by = .(SITE_ID, M_YEAR, WEEK)][,sum(FITTED), by = .(SITE_ID, M_YEAR)]
            } else {
                b_day <- site_year_sp_count$impute_count[COMPLT_SEASON == 1 & M_SEASON != 0, FITTED, by = .(SITE_ID, M_YEAR, WEEK)][,sum(FITTED), by = .(SITE_ID, M_YEAR)]
            }

            data.table::setnames(b_day,"V1","BUTTERFLY_DAY")

        return(b_day)
    }


# visualisations of changing satisfaction with democracy over time

# james goldie & michael joiner, 360info, dec 2021

library(tidyverse)
# remotes::install_github("360-info/themes360info")
library(themes360info)
library(ragg)
library(png)
library(svglite)
library(ggtext)
library(lubridate)
library(here)

# ---- a) by education level --------------------------------------------------

education <-
  read_csv(
    here("data", "bes-panel-education.csv"), skip = 1,
    col_names = c("date", "gcse_lte", "alevel", "university")) %>%
  # clean up the dates
  mutate(
    month = str_sub(date, 1, 3),
    year = str_sub(date, 6, 7),
    date = ymd(paste0(year, "-", month, "-15"))) %>%
  select(-month, -year) %>%
  # put the university levels into on column
  pivot_longer(-date, names_to = "edu_level", values_to = "satisfaction") %>%
  mutate(
    edu_level = factor(edu_level,
      levels = c("gcse_lte", "alevel", "university"),
      labels = c("GCSE or lower", "A-Levels", "University")))

ggplot(education) +
  aes(date, satisfaction, colour = edu_level) +
  geom_line() +
  geom_point(size = 3) +
  scale_y_continuous(limits = c(0, 1), labels = scales::percent) +
  theme_360() +
  theme(
    legend.position = c(0.99, 0.9),
    legend.direction = "horizontal",
    legend.justification = c(1, 0.5),
    plot.caption = element_markdown(size = rel(0.9))) +
  labs(
    x = NULL, y = NULL,
    colour = "Education level",
    title = toupper("Satisfaction in UK Democracy"),
    caption = "**SOURCE:** TrustGov survey, conducted by Ipsos MORI
in May 2020") ->
edu_chart

dir.create(here("out"))
register_360fonts("itc")
save_360plot(edu_chart, here("out", "uk-edu-chart.png"),
  shape = "sdtv-landscape")
register_360fonts("libre")
save_360plot(edu_chart, here("out", "uk-edu-chart.svg"),
  shape = "sdtv-landscape")

# ---- a) by leave/remain -----------------------------------------------------

brexit <-
  read_csv(
    here("data", "bes-panel-brexit.csv"), skip = 1,
    col_names = c("date", "remian", "leave")) %>%
  # clean up the dates
  mutate(
    month = str_sub(date, 1, 3),
    year = str_sub(date, 6, 7),
    date = ymd(paste0(year, "-", month, "-15"))) %>%
  select(-month, -year) %>%
  # put the university levels into on column
  pivot_longer(-date, names_to = "position", values_to = "satisfaction") %>%
  mutate(
    position = factor(position,
      levels = c("remian", "leave"),
      labels = c("Remain", "Leave")))

ggplot(brexit) +
  aes(date, satisfaction, colour = position) +
  geom_line() +
  geom_point(size = 3) +
  scale_y_continuous(limits = c(0, 1), labels = scales::percent) +
  theme_360() +
  theme(
    legend.position = c(0.99, 0.9),
    legend.direction = "horizontal",
    legend.justification = c(1, 0.5),
    plot.caption = element_markdown(size = rel(0.9))) +
  labs(
    x = NULL, y = NULL,
    colour = "Brexit position",
    title = toupper("Satisfaction in UK Democracy"),
    caption = "**SOURCE:** TrustGov survey, conducted by Ipsos MORI
in May 2020") ->
brexit_chart

dir.create(here("out"))
register_360fonts("itc")
save_360plot(brexit_chart, here("out", "uk-brexit-chart.png"),
  shape = "sdtv-landscape")
register_360fonts("libre")
save_360plot(brexit_chart, here("out", "uk-brexit-chart.svg"),
  shape = "sdtv-landscape")


context("coloc")
library(gwasglue)

fn <- system.file("extdata","data.vcf.gz", package="gwasvcf")
vcf1 <- readVcf(fn)
vcf2 <- readVcf(fn)

test_that("coloc vcf", {
	a <- gwasvcf_to_coloc(vcf1, vcf2, "1:1-100000000")
	expect_true(is.list(a))

	b <- expect_warning(coloc::coloc.abf(a$dataset1, a$dataset2))
	expect_true(is.list(b))
})

test_that("coloc ieugwasr", {
	chrpos <- "1:109724880-109904880"
	out <- expect_warning(ieugwasr_to_coloc(id1='ieu-a-300', id2='ieu-a-7', chrompos=chrpos))
	b <- expect_warning(coloc::coloc.abf(out$dataset1, out$dataset2))
	expect_true(is.list(b))
})

test_that("arth bbj", {
	chrpos <- "1:38228579-38328579"
	out <- ieugwasr_to_coloc(id1='bbj-a-73', id2='bbj-a-73', chrompos=chrpos, type1 = "cc", type2 = "cc")
	res <- coloc::coloc.abf(out$dataset1, out$dataset2)
	expect_true(res$summary[6] > 0.8)
})

test_that("coloc ieugwasr 2", {
	chrpos <- "1:47634677-47734677"
	out <- expect_warning(ieugwasr_to_coloc("ieu-a-2", "eqtl-a-ENSG00000162366", chrpos))
	res <- expect_warning(coloc::coloc.abf(out$dataset1, out$dataset2))
})


.ops = import('../base/operators')

#' Intersect two GRanges objects
#'
#' See GenomicRanges/IRanges::findOverlaps for detailed arg docs
#'
#' @param query       GRanges object used as query
#' @param subject     GRanges object used as subject
#' @param type        Type of the overlap, eg. 'any', 'start', 'end', 'within'
#' @param minoverlap  Minimum number of positions that need to overlap to count
#' @param select      Which match to return (eg. 'first', 'last'; default: 'all')
#' @param return_widths  Return width of match and fraction of query covered
#' @param keep_index  Return indices in query and subject
#' @param ...         Further arguments passed to findOverlaps
#' @return            Merged data.frame based on overlaps
intersect = function(query, subject, type="any", minoverlap=0L, select="all",
                     return_widths=FALSE, keep_index=FALSE, ...) {

    cols_query = GenomicRanges::mcols(query) %>%
        as.data.frame() %>%
        dplyr::mutate(seqnames = as.character(GenomicRanges::seqnames(query)),
                      queryHits = seq_len(nrow(.)))

    cols_subject = GenomicRanges::mcols(subject) %>%
        as.data.frame() %>%
        dplyr::mutate(subjectHits = seq_len(nrow(.)))

    re = GenomicRanges::findOverlaps(
        query, subject, type=type, minoverlap=minoverlap, select=select, ...)

    re = re %>%
        as.data.frame() %>%
        dplyr::left_join(cols_query, by="queryHits") %>%
        dplyr::left_join(cols_subject, by="subjectHits")

    if (return_widths) {
        overlaps = GenomicRanges::pintersect(
            query[re$queryHits], subject[re$subjectHits])

        re = re %>%
            dplyr::mutate(query_width = GenomicRanges::width(query[re$queryHits]),
                ov_frac = GenomicRanges::width(overlaps) / query_width)
    }

    if (keep_index)
        re
    else
        dplyr::select(re, -queryHits, -subjectHits)
}


#!/usr/bin/env Rscript --vanilla
# download and combine gapminder and berkeley earth data
# james goldie ('rensa'), august 2017

library(RCurl)
library(rvest)
library(tidyverse)
library(magrittr)
library(stringr)
library(fuzzyjoin)
filter = dplyr::filter # this is going to kill me one day
source('util.r')

# constants
on_url = 'https://raw.githubusercontent.com/open-numbers/'
berk_url = 'http://berkeleyearth.lbl.gov/auto/Regional/TAVG/Text/'
year_start = 1900
year_end = 2012

# create data directory if it's missing
if(!dir.exists('data'))
{
  dir.create('data')
}

# download gapminder files if they're missing
gap_files = data_frame(
  repo = c(
    'ddf--gapminder--population',
    'ddf--cait--historical_emissions',
    'ddf--gapminder--gdp_per_capita_cppp',
    'ddf--gapminder--population',
    'ddf--cait--historical_emissions'),
  file = c(
    'ddf--entities--geo--country.csv',
    'ddf--entities--country.csv',
    'ddf--datapoints--gdp_per_capita_cppp--by--geo--time.csv',
    'ddf--datapoints--population--by--country--year.csv',
    paste0(
      'ddf--datapoints--total_co2_emissions_excluding_land_use_change_and_',
      'forestry_mtco2--by--country--year.csv')),
  remote_url = paste0(on_url, repo, '/master/', file),
  local_path = paste0('data/gapminder/', file))
gap_files_to_download = which(!file.exists(gap_files$local_path))
if (length(gap_files_to_download) > 0)
{
  message(run.time(), ' downloading missing gapminder data')
  mapply(download.file,
    gap_files$remote_url[gap_files_to_download],
    destfile = gap_files$local_path[gap_files_to_download])
} else
{
  message(run.time(), ' found all gapminder data')
}

# load and tidy gapminder country code maps
message(run.time(), ' loading and tidying any missing gapminder data')
geo_gap =
  read_csv('data/gapminder/ddf--entities--geo--country.csv', na = c('')) %>%
  select(country, gapminder_list, alternative_1, alternative_2,
    iso3166_1_alpha2, world_6region, income_groups) %>%
  rename(name = gapminder_list)
geo_co2 =
  read_csv('data/gapminder/ddf--entities--country.csv', na = c('')) %>%
  rename(name_co2 = name)

# load and tidy gapminder data sets
gdp_percap =
  read_csv(paste0(
    'data/gapminder/',
    'ddf--datapoints--gdp_per_capita_cppp--by--geo--time.csv'), na = c('')) %>%
  rename(country = geo, year = time, gdppc = gdp_per_capita_cppp) %>%
  filter(year >= year_start & year <= year_end) %>%
  inner_join(geo_gap) %>%
  select(name, year, gdppc, alternative_1, alternative_2,
    iso3166_1_alpha2, world_6region, income_groups) %>%
  # namibia is a pain in the butt because of its code is NA
  mutate(iso3166_1_alpha2 = case_when(
    name == 'Namibia' ~ 'NA',
    TRUE ~ iso3166_1_alpha2)) %>%
  mutate(world_6region = recode(world_6region,
    'europe_central_asia' = 'Europe + Central Asia',
    'south_asia' = 'South Asia',
    'sub_saharan_africa' = 'Sub-Saharan Africa',
    'america' = 'America',
    'middle_east_north_africa' = 'Middle East + North Africa',
    'east_asia_pacific' = 'East Asia + Pacific'))
pop =
  read_csv(paste0(
    'data/gapminder/',
    'ddf--datapoints--population--by--country--year.csv'), na = c('')) %>%
  filter(year >= year_start & year <= year_end) %>%
  inner_join(geo_gap) %>%
  select(name, year, population, alternative_1, alternative_2,
    iso3166_1_alpha2)
co2 =
  read_csv(paste0(
    'data/gapminder/','ddf--datapoints--total_co2_emissions_excluding_land_use_change_','and_forestry_mtco2--by--country--year.csv'), na = c('')) %>%
  rename(
    co2 = total_co2_emissions_excluding_land_use_change_and_forestry_mtco2) %>%
  filter(year >= year_start & year <= year_end) %>%
  inner_join(geo_co2) %>%
  select(name_co2, year, co2)

# combine gapminder datasets,
# rank countries each year by their gdp per capita
# calculation global pop, pop fraction and number of poorer people each year
message(run.time(), ' combining gapminder data')
gapdata = gdp_percap %>% inner_join(pop)
gapdata =
  bind_rows(list(
    co2 %>% inner_join(gapdata,
      by = c('name_co2' = 'name', 'year' = 'year')),
    co2 %>% inner_join(gapdata,
      by = c('name_co2' = 'alternative_1', 'year' = 'year')),
    co2 %>% inner_join(gapdata,
      by = c('name_co2' = 'alternative_2', 'year' = 'year')))) %>%
  select(-name, -alternative_1, -alternative_2) %>%
  rename(name = name_co2)
gapdata$flag_emoji =
  iso_to_emoji_unicode(gapdata$iso3166_1_alpha2)
gapdata$flag_file_basename =
  iso_to_emoji_ascii(gapdata$iso3166_1_alpha2)
gapdata %<>%
  mutate(annual_devrank = ave(gdppc, year, FUN = rank)) %>%
  group_by(year) %>%
  arrange(annual_devrank) %>%
  mutate(
    pop_global = sum(population),
    pop_fraction = population / pop_global,
    pop_poorer = cumsum(population) - population,
    pop_poorer_fraction = pop_poorer / pop_global) %>%
  ungroup() %>%
  group_by(name) %>%
  arrange(year) %>%
  mutate(co2_cum = cumsum(co2)) %>%
  ungroup() %>%
  mutate(., emission_id = group_indices(., name, year))

# scrape a list of available berkeley earth country temp data files and
# match them fuzzily against gapdata countries
message(run.time(), ' scraping list of available berkeley temperature data')
berk_files =
  data_frame(
    filename = berk_url %>% read_html %>% html_nodes('a') %>% html_text) %>%
  slice(-(1:6)) %>%
  mutate(
    name_lowercase = str_replace(filename, '-TAVG-Trend.txt', '')) %>%
  # drop some tricky rows (utf escaping problems? TODO)
  filter(!name_lowercase %in% c('pará', 'côte-d\'ivoire'))

# okay, now do a loose fuzzy match between gapminder names and berkeley names and choose the best reuslts for each gapminder file. this strips out whitespace and punctuation first, as they bias the fuzzy matching algorithm
message(run.time(), ' fuzzy joining gapminder and berkeley country names')
gapdata_names = data_frame(
  name = unique(gapdata$name),
  name_nopunc = str_to_lower(str_replace_all(name, ' ', '')))
name_matches =
  data_frame(
    name_lowercase = unique(berk_files$name_lowercase),
    name_lowercase_nopunc = str_replace_all(name_lowercase, '-', ''))

name_matches %<>%
  stringdist_inner_join(gapdata_names, by = c(name_lowercase_nopunc = 'name_nopunc'),
    max_dist = 5, distance_col = 'match_dist') %>%
  group_by(name) %>%
  top_n(-1, wt = match_dist) %>%
  ungroup() %>%
  filter(match_dist <= 1) %>%
  select(name, name_lowercase, match_dist)

# now bolt the matches onto the berkeley list and the gapminder data
berk_files %<>% inner_join(name_matches, by = 'name_lowercase')
gapdata %<>% inner_join(name_matches, by = 'name')

# TODO - got about 160 countries between all datasets at this point
# might need to fiddle with the strings to get the edge cases...

# download berkeley files, tag each one with the country and bind them together
temp =
  lapply(
    berk_files$name_lowercase, function(x)
    {
      if (!file.exists(paste0('data/berkeley/', x, '-TAVG-Trend.txt')))
      {
        message(run.time(), ' downloading berkeley temperature data for ', x)
        download.file(paste0(berk_url, x, '-TAVG-Trend.txt'),
          destfile = paste0('data/berkeley/', x, '-TAVG-Trend.txt'))
      } else
      {
        message(run.time(), ' found berkeley temperature data for ', x)
      }
      read_table2(
        paste0('data/berkeley/', x, '-TAVG-Trend.txt'),
        comment = '%', skip = 1, col_types = 'ii--dd------',
        col_names = FALSE) %>%
        mutate(name_lowercase = x)
    }) %>%
  bind_rows %>%
  rename(year = X1, month = X2, temp = X5, temp_unc = X6) %>%
  filter(year >= year_start & year <= year_end & month == 6) %>%
  select(-month) %>%
  mutate(
    temp_min = temp - temp_unc,
    temp_max = temp + temp_unc) %>%
  inner_join(name_matches, by = 'name_lowercase')

# finally, join the datasets together
message(run.time(), ' joining berkeley and gapminder data')
all_data =
  inner_join(gapdata, temp,
    by = c('name', 'name_lowercase', 'year', 'match_dist'))
write_csv(all_data, 'data/gapminder-berkeley-tidy.csv')

message(run.time(), ' done!')