############################################
# START OF PROGRAM #  Bootstock 3.2
# 14 Febuary 2020

# This program was written primarily to analyze AD-clip only sport fisheries however it can be used for
# unclipped fisheries (i.e Tribal). I recommend that the Adipose clipped and adipose unclipped
# fisheries be run separately.

# Version 3.1 edits and changes ###############

# 1-10-18 fix bug changed code::: names(new.prop)<-1:b
# to:: names(new.prop)<-1:bootstraps

#1/19/18--made edits to notes. Add start and end time calculation.

# 1/23/18--fix bug in cases where only 0 or 1 GSI groups (rowSums function needs at least 2 columns)
# edit Loop 3.1 and add Loops 3.1.a and 4.1 to address this case.

# 2/6/18.  add Basin summary for GSI only and PBT only ################

# New features
# (1) add Stock and Basin to input data file (assignment.table)
# (2) Fix point estimates and Bootstrap iterations to prevent negative proportions
# (3) add adjustment loop in re-allocation loop to subtract all of the expanded PBT
# amount from GSI groups that were sampled if the PBT amount is < rowSum of all GSI groups
# in the group.freq (freq.table for the bootstrap iteration).  If expanded PBT >= rowSum
# of all GSI groups--then set all GSI groups to zero and use expanded total to calculate
# harvest proportions. This is done in Loops 2.5 (for point estimates) and 3.7 (for
# bootstrap iterations).
# (4) Summary of results writen to csv files for groups, stocks, rear (H = PBT; U = GSI),
# and basin.  Summary files have the actual sample size, expanded PBT/adjusted GSI sample
# size, harvest proportion, lower and upper CI (default = 90% but user can change), and
# the mean harvest proportion, standard deviation, and CV of the bootstrap iterations.
############################################################################################

# Version 3.2 released 2/14/20 with change to reallocation routine

# 2/14/20. changed how reallocation table is dervied. Now only the GSI groups that were
# sampled (and the proportion assigning to PBT stocks) are used in re-allocation loop.

# changed "hatchery_fish_release_location" to "reallocate_stock" for reallocation loop
# and in the csv assignment and reallocation input files

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

# Remove current objects that may be in workspace

rm(list=ls())
start.time<-Sys.time()

library(data.table)   # used in program. created in older R version.
 library(dplyr)       # used in program. created in older R version.

######################################
# SET WORKING DIRECTORY
######################################

# Set the working file directory. The 3 input files listed below should
# be placed in this directory.  Output files (specified at end of program)
# will be written to this directory.

setwd("C:/Users/........................../")

getwd() # Make sure its a valid directory.

##################################################################
# USER-DEFINED INPUT FILES- enter filename after <- read.csv(??.
# enclose filename with ???????..xxx? where xxx = file extension
# recommend using csv format available in Excel. 3 files required.
# example files provided
###################################################################

# 1) input data file of group assignments [PBT & GSI], rear, stock, basin
# 2) PBT hatchery/brood year tagging rates,
# 3) reallocation table

assignment.table  <- read.csv("LCR Sport All 2019.csv",header=TRUE)

tag.rate.table    <- read.csv("Tag_Rate_6-4-20.csv", header=TRUE)

reallocation.table<- read.csv("Reallocation Table_3-12-20.csv", header=TRUE)

## replace missing values with zero in reallocation.table

reallocation.table[is.na(reallocation.table)] = 0

## for naming the output files of Results create text string next

 output<-"LCR Sport 2019 All.csv"

#########################################################################
# Set number of bootstrap resamples and CI.  Default is 10000 iterations
# and 90% CI.  Enter CI as a proportion (i.e 90% = 0.9)
##########################################################################

bootstraps <- 10000
ci         <- .90

######################################################################
# GENERATE HARVEST PROPORTION ESTIMATES PRIOR TO CI BOOTSTRAP ROUTINE #
#######################################################################

# Tabulate actual sample count of PBT & GSI group

group.freq <- as.data.frame(matrix(table(assignment.table$group_assignment),1,length(unique(assignment.table$group_assignment))))

# Add headers (group names) to the data frame

names(group.freq) <- names(table(assignment.table$group_assignment))
group.freq

# Create a list of all 'unique' group names in the group_assignment column of # the assignment.table

group.names <- unique(assignment.table$group_assignment)
group.names

# Generate lists of hatchery and 'wild' groups using the 'rear' column in
# the assignment.table

hatchery.list <- as.character(unique(assignment.table$group_assignment[which(assignment.table$rear=="H")]))

wild.list <- as.character(unique(assignment.table$group_assignment[which(assignment.table$rear=="U")]))

### choose GSI groups that were sampled for reallocation table

reallocation.table <- reallocation.table[, colnames(reallocation.table) %in% c("reallocate_stock", wild.list)]
for(i in 1:nrow(reallocation.table))
{
  if(sum(reallocation.table[i,2:ncol(reallocation.table)]) == 0) reallocation.table[i,2:ncol(reallocation.table)] <- 1
  reallocation.table[i,2:ncol(reallocation.table)] <- reallocation.table[i,2:ncol(reallocation.table)] /
                                                        sum(reallocation.table[i,2:ncol(reallocation.table)])
}

## create a list of distinct hatchery stocks

distinct.hatchery.stock.names <- as.character(unique(assignment.table$stock_assignment[which(assignment.table$rear=="H")]))

# Determine sample size in the assignment.table. The sample size is used to
# set the number of individuals that will be re-sampled during
# each iteration in the bootstrapping routine below.

sample.size <- length(assignment.table$individual)  ## all samples
sample.size

wild.sample.size<-length(assignment.table$individual[which((assignment.table$group_assignment) %in% wild.list)])
wild.sample.size    ## GSI samples only

#### BEGIN PBT EXPANSION using Tag rates  Loop 1  ########################

exp.point.ests <- group.freq
for (hatchery.by in hatchery.list)
{ #1.1
  if (hatchery.by %in% tag.rate.table[,1])
  {  #1.2
exp.point.ests[1,hatchery.by] <- group.freq[hatchery.by] /
tag.rate.table[as.character(tag.rate.table[,1])==hatchery.by,2]
  }  #1.2
}  #1.1

### END PBT EXPANSION LOOP 1 ############################################

# Calculate the number of fish that were added to each PBT stock (rear = H).  This is
# the amount that we must subtract from the GSI stocks (rear = U)

exp.point.ests.diff <- exp.point.ests[,hatchery.list] - group.freq[,hatchery.list]

## if the expanded total - sample.size > GSI sample size, set all GSI groups to 0
## proportions of hatchery groups will be expanded / sum(expanded). All GSI proportions = 0.

if(rowSums(exp.point.ests.diff) >= wild.sample.size)  # set all GSI groups to 0
  {
    exp.point.ests[,wild.list]<- 0
  }

### BEGIN GSI -> PBT REALLOCATION LOOP 2 ONLY if exp.point.ests < wild.sample.size ####

# subtract the expanded - actual PBT amount from appropriate GSI groups
# using reallocation table that allocates the Expand-Actual PBT difference
# to the GSI groups.  This amount is the amount that would have been assigned
# to the GSI group if there was no PBT assignment.  If the GSI group is < 0
# after the subtraction, then set GSI group to 0 to avoid negative
# proportions. If there were no actual assignments to the GSI group it will
# be 0%.  exp.point.ests matrix will have the counts for each PBT/GSI group
# after the reallocation,  These counts will be used to calculate the
# proportions of all groups.  Only GSI groups that were sampled will appear
# after the re-allocation.

if(rowSums(exp.point.ests.diff) < wild.sample.size)  ## do re-allocation loop
{  #2.1

for (hatchery.by in hatchery.list)
{ #2.2

hatchery.release <- as.character(unique(assignment.table$reallocate_stock
[which(assignment.table$group_assignment==hatchery.by)]))

for (rg in wild.list)
{ #2.3

  if(any(names(reallocation.table)==rg))

 { #2.4
exp.point.ests[,rg]  <-ifelse(exp.point.ests[,rg] -
(exp.point.ests.diff[1,hatchery.by]*reallocation.table[which(reallocation.table$reallocate_stock==hatchery.release),rg])<=0,0,exp.point.ests[,rg] -
(exp.point.ests.diff[1,hatchery.by]*reallocation.table[which(reallocation.table$reallocate_stock==hatchery.release),rg]))
       } #2.4
     }    #2.3
   }       #2.2

 while (rowSums(exp.point.ests) > sample.size)
  { #2.5

for (rg in wild.list)
{  #2.6

aa = (rowSums(exp.point.ests) - rowSums(group.freq))/length(exp.point.ests[which(!exp.point.ests==0 & colnames(exp.point.ests) %in% wild.list)])

exp.point.ests[,rg]<-ifelse((exp.point.ests[,rg] - aa)<=0,0,exp.point.ests[,rg] - aa)
 } #2.6
  }  # 2.5
    } # 2.1

# Here are our point estimates (rounded to 4 decimal places)

point.estimates <- exp.point.ests/rowSums(exp.point.ests)
round(point.estimates,4)

#######    Bootstrap   LOOP 3        ##############################################

## BEGIN BOOTSTRAPPING LOOP TO CALCULATE CIs AND CVS FOR EACH group ######

# Create empty data frame to store frequencies from each bootstrap iteration
# of group assignment resampling

freq.table <- as.data.frame(matrix(rep(NA,(bootstraps*length(group.names))),bootstraps,length(group.names)))

names(freq.table) <- group.names

#### An empty table s groups wide by b bootstraps long ###

head(freq.table)

#### BEGIN BOOTSTRAP LOOP -- this may take a few minutes depending on sample size and the number of bootstraps

for (b in 1:bootstraps)
{
resample <- sample(x = as.character(assignment.table$group_assignment),size = sample.size, replace =TRUE)

freq.table[b,] <- lapply(as.character(group.names), function(x) length(resample[resample==x]))
}

# Now the freq.table is filled out with counts from each bootstrap

head(freq.table)

# Now the PBT group counts within each bootstrap iteration must be expanded
# by its PBT tagging rates

# Copy the freq.table to a new table called expansion.table

expansion.table <- freq.table
head(expansion.table)

### BEGIN EXPANSION LOOP ACROSS ALL ITERATIONS IN the expansion.table ####

for (hatchery.by in hatchery.list)
{
  if (hatchery.by %in% tag.rate.table[,1])
    {
expansion.table[,hatchery.by] <- as.numeric(freq.table[,hatchery.by]) / tag.rate.table[as.character(tag.rate.table[,1])==hatchery.by,2]
}
else
 {
print(paste(hatchery.by, "has no tagging rate defined in tag_rates.csv"))
  }
    }
#### END EXPANSION LOOP ###

### ADJUST the GSI group COUNTS####

# These are the numbers that we added to each hatchery group in each
# bootstrap iteration

exp.diff.table <- expansion.table[,hatchery.list] - freq.table[,hatchery.list]
# count.present<-sum(freq.table[,wild.list]==0)

## if the expanded total - sample.size > GSI sample size, set all GSI groups to 0
## proportions of hatchery groups will be expanded / sum(expanded). All GSI proportions = 0.

if (length(wild.list) > 1)  #Need at least 2 GSI groups present for rowSums() function
   { 3.1                    #and to reallocate to multiple groups in loops 3.x

for (b in 1:bootstraps) # check rowSums of each iteration.
 {  #3.1a

if(rowSums(exp.diff.table[b,]) >= rowSums(freq.table[b,wild.list])) # set all GSI groups to 0
  {  #3.2
    expansion.table[b,wild.list]<- 0
  }  #3.2

#### REALLOCATION LOOP for the iteration in expansion.table #####
####    if the rowSums(exp.diff.table) < wild.sample.size) #####

# subtract the expanded - actual PBT amount from appropriate GSI groups
# using reallocation table to allocate the Expand-Actual PBT difference
# from the GSI groups.  This amount is the amount that would have been
# assigned to each GSI group if there was no PBT assignment.  If the GSI
# group is < 0 after the subtraction, then set GSI group to 0 to avoid
# negative proportions.  GSI groups that were not in the actual sample
# will not appear in the expansion.table.
###############################################################

if(rowSums(exp.diff.table[b,]) < rowSums(freq.table[b,wild.list]))
 {   #3.3

for (hatchery.by in hatchery.list)
{ #3.4
hatchery.release <- as.character(unique(assignment.table$reallocate_stock[which(assignment.table$group_assignment==hatchery.by)]))

for (rg in wild.list)
  {  #3.5

  if(any(names(reallocation.table)==rg))
    {  #3.6

expansion.table[b,rg] <-ifelse(expansion.table[b,rg] -
(exp.diff.table[b,hatchery.by]*reallocation.table[which(reallocation.table$reallocate_stock==hatchery.release),rg])<=0,
0,expansion.table[b,rg] - (exp.diff.table[,hatchery.by]*reallocation.table[which(reallocation.table$reallocate_stock==hatchery.release),rg]))

}  #3.6
  }  #3.5
   }  #3.4

####  Adjustment loop for reallocation of GSI groups not sampled.  Loop 3a **********

## Since an itereation many not have had all GSI groups that had a "re-allocation value" to subtract the rowSums of this iteration
## will be > the sample size.  This loop subtracts this amount from the GSI groups present.  Once completed the sum of all PBT and
## GSI groups in the expansion.table will = the sample size for the iteration.  This loop is only excuted when wild.sample.size
## < the (PBT expanded - PBT actual count). If (PBT expanded - PBT actual count) >= wild.sample.size this loop (and Loop 3.3)
## is not run because  all GSI groups were set to zero in Loop 3.2.

 while (rowSums(expansion.table[b,]) > sample.size)
  {  # 3.7

bb=(rowSums(expansion.table[b,])-sample.size)/length(expansion.table[which(!expansion.table[b,]== 0 & colnames(expansion.table[b,]) %in% wild.list)])

for (rg in wild.list)
{ #3.8
expansion.table[b,rg] <- ifelse(expansion.table[b,rg]-bb <=0,0,expansion.table[b,rg]-bb)
} #3.8
  }  #3.7
    } #3.3
   }  # 3.1.a   and go to the next iteration
 } #3.1  # End adjustment loop 3

## Now deal with datasets that have 1 GSI groups in the sample.  If no
## GSI groups were present the reallocation loop 3 will not execute
## and harvest proportions will use expanded total not sample size in
## the denominator.

 if (length(wild.list) == 1)  # subtract all from this group
 { #4.1

exptot <-data.frame(rowSums(exp.diff.table))
  expansion.table[,wild.list]<-ifelse(expansion.table[,wild.list]-exptot[,1]<=0,0,expansion.table[,wild.list]-exptot[,1])

 } # 4.1

# Create a table of group proportions for each iteration. Every value in each
# column in Row i is divided by the rowSums of Row i.  Each rowSums = sample
# size if (PBT expansion - PBT actual)  < GSI actual.  if (PBT expansion count - PBT actual)
#  >= GSI actual then all GSI groups = 0 and PBT group proportions found by diviving
# PBT expand count by expanded rowSums (which will be > sample.size)

prop.table <- expansion.table / rowSums(expansion.table)

head(prop.table)

####Generate summary statistics from the 'prop.table'################

# Calculate the Lower CI, Upper CI, Mean of iterations, standard deviation of
# iterations, and coefficient of variation

results.boot    <- data.frame(group_assignment=names(prop.table), lci=apply(prop.table, 2, quantile, (1-ci)/2), uci=apply(prop.table, 2, quantile, ((1-ci)/2)+ci), mean=apply(prop.table, 2, mean), st.dev=apply(prop.table, 2, sd))
results.boot$cv <-(results.boot$st.dev/results.boot$mean)*100

### making a dataframe from the transposed point estimates, actual count,
### and adjusted count used for point estimate

results.point <- data.frame(Proportion=t(point.estimates),Actual=t(group.freq),Adjusted=t(exp.point.ests))

# adding a reporting group column
results.point$group_assignment <- row.names(results.point)

## all stats by group_assignment
results.group<-merge(results.point, results.boot, by="group_assignment")

### Summarize prop.table by hatchery stock, rear, basin by summing release
# groups (group_assignments)

all.groups.stocks<-subset(assignment.table,select = -c(individual,reallocate_stock))

distinct.groups<-unique(all.groups.stocks, by = "group_assignment")
 rownames(distinct.groups)<-distinct.groups$group_assignment

## bootstrap iterations by group_assignment
new.prop<-data.frame(t(prop.table))
 names(new.prop)<-1:bootstraps

## new column with group_assignment names
new.prop$group_assignment<-rownames(new.prop)

stock.rear.groups<-merge(x=new.prop, y = distinct.groups, by = "group_assignment", all.x = TRUE)

 stock.prop<-subset(stock.rear.groups,select = -c(group_assignment,rear,basin))

rear.prop<-subset(stock.rear.groups,select = -c(group_assignment,stock_assignment,basin))
    basin.prop<-subset(stock.rear.groups,select = -c(group_assignment,stock_assignment,rear))

##sum all stocks in each iteration- to get CIs by stock  ###

stock.ci=stock.prop %>% group_by(stock_assignment) %>% summarise_all(funs(sum))

### get lci and uci, mean, std of bootstrap iterations for each stock

## delete column with stock names, keep everything else the same as stock.ci

new<-subset(stock.ci, select = -c(stock_assignment))

stock.lci.uci<-data.frame(stock=stock.ci$stock_assignment,lci=apply(new,1,quantile,(1-ci)/2),uci=apply(new,1,quantile, ((1-ci)/2)+ci),mean=apply(new,1,mean),st.dev=apply(new,1,sd))

stock.lci.uci$cv<-(stock.lci.uci$st.dev/stock.lci.uci$mean)*100

## by rear type - find CIs###

rear.ci=rear.prop %>% group_by(rear) %>% summarise_all(funs(sum))

## delete column with rear type, keep everything else the same as rear.ci
 new2<-subset(rear.ci, select = -c(rear))

rear.lci.uci<-data.frame(rear=rear.ci$rear,lci=apply(new2,1,quantile,(1-ci)/2),uci=apply(new2,1,quantile, ((1-ci)/2)+ci),mean=apply(new2,1,mean),st.dev=apply(new2,1,sd))

rear.lci.uci$cv<-(rear.lci.uci$st.dev/rear.lci.uci$mean)*100

## by basin - find Cis using all samples###

basin.ci=basin.prop %>% group_by(basin) %>% summarise_all(funs(sum))

# delete column with basin, keep everything else the same as basin.ci
 newbasin<-subset(basin.ci, select = -c(basin))

basin.lci.uci<-data.frame(basin=basin.ci$basin,lci=apply(newbasin,1,quantile,(1-ci)/2),uci=apply(newbasin,1,quantile, ((1-ci)/2)+ci),mean=apply(newbasin,1,mean),st.dev=apply(newbasin,1,sd))

basin.lci.uci$cv<-(basin.lci.uci$st.dev/basin.lci.uci$mean)*100

## Get point estimates by stock, rear type, and basin (all samples)

new.point<-data.frame(t(point.estimates))

# new column with group_assignment names
 new.point$group_assignment<-rownames(new.point)

point.stock.rear.groups<-merge(x=new.point, y = distinct.groups, by = "group_assignment", all.x = TRUE)

point.stock<-subset(point.stock.rear.groups,select = -c(group_assignment,rear,basin))

point.rear<-subset(point.stock.rear.groups,select = -c(stock_assignment,group_assignment,basin))

point.basin<-subset(point.stock.rear.groups,select = -c(stock_assignment,group_assignment,rear))

stock.point.estimate=point.stock %>% group_by(stock_assignment) %>% summarise_all(funs(sum))

rear.point.estimate=point.rear %>% group_by(rear) %>% summarise_all(funs(sum))

basin.point.estimate=point.basin %>% group_by(basin) %>% summarise_all(funs(sum))

### get actual and adjusted sample size by stock #####

new.group.freq<-data.frame(t(group.freq))
  new.group.freq$group_assignment<-rownames(new.group.freq)
   new.group<-merge(x=new.group.freq, y = distinct.groups, by = "group_assignment", all.x = TRUE)
    new3<-subset(new.group,select = -c(group_assignment,rear,basin))

stock.freq=new3 %>% group_by(stock_assignment) %>% summarise_all(funs(sum))

new.exp.point.ests<-data.frame(t(exp.point.ests))
  new.exp.point.ests$group_assignment<-rownames(new.exp.point.ests)
   new.ests<-merge(x=new.exp.point.ests, y = distinct.groups, by = "group_assignment", all.x = TRUE)
     new4<-subset(new.ests,select = -c(group_assignment,rear,basin))

stock.adjust=new4 %>% group_by(stock_assignment) %>% summarise_all(funs(sum))

### get actual and adjusted sample size by rear and basin #####
## by rear actual##
new5<-subset(new.group,select = -c(group_assignment,stock_assignment,basin))

## by basin actual##
 new6<-subset(new.group,select = -c(group_assignment,stock_assignment,rear))

rear.freq=new5 %>% group_by(rear) %>% summarise_all(funs(sum))

basin.freq=new6 %>% group_by(basin) %>% summarise_all(funs(sum))

## by rear adjusted##
new7<-subset(new.ests,select = -c(group_assignment,stock_assignment,basin))

## by basin adjusted##
new8<-subset(new.ests,select = -c(group_assignment,stock_assignment,rear))

rear.adjust=new7 %>% group_by(rear) %>% summarise_all(funs(sum))

basin.adjust=new8 %>% group_by(basin) %>% summarise_all(funs(sum))

######  write results to data frame ####

## by stock ###

res1<-merge(stock.point.estimate,stock.freq)
 res2<-merge(res1,stock.adjust)
   setnames(res2, old = c(1,2,3,4), new = c('stock','proportion','actual','adjusted'))

 ## all results by stock (actual,adjust,proportion,lci,uci,mean,std,cv)

all.results.stock<- merge(res2,stock.lci.uci)  ## all results by stock (actual,adjust,proportion,lci,uci,mean,std,cv)

## by rear ###

res3<-merge(rear.point.estimate,rear.freq)
 res4<-merge(res3,rear.adjust)
   setnames(res4, old = c(1,2,3,4), new = c('rear','proportion','actual','adjusted'))

all.results.rear<- merge(res4,rear.lci.uci)  ## all results by rear (actual,adjust,proportion,lci,uci,mean,std,cv)

## by basin using all samples###

res5<-merge(basin.point.estimate,basin.freq)
 res6<-merge(res5,basin.adjust)
   setnames(res6, old = c(1,2,3,4), new = c('basin','proportion','actual','adjusted'))

all.results.basin<- merge(res6,basin.lci.uci)

## calculate CI's, bootstrap mean, st dev, cv for stocks identified with
## PBT (rear="H") by basin. These basin results exclude GSI assigned fish.

pbt.only<-subset(stock.rear.groups,rear=="H",select = -c(group_assignment,stock_assignment,rear))

pbt.only.basin = pbt.only %>% group_by(basin) %>% summarise_all(funs(sum))

pbt0<-subset(pbt.only.basin, select = -c(basin))

pbt.basin.lci.uci<- data.frame(basin=pbt.only.basin$basin,lci=apply(pbt0,1,quantile,(1-ci)/2),uci=apply(pbt0,1,quantile,((1-ci)/2)+ci), mean=apply(pbt0,1,mean),st.dev=apply(pbt0,1,sd))

pbt.basin.lci.uci$cv<-(pbt.basin.lci.uci$st.dev/pbt.basin.lci.uci$mean)*100

## point estimates for PBT only by basin
pbt1<-subset(point.stock.rear.groups,rear=="H",select = -c(group_assignment,stock_assignment,rear))
 pbt.only.point = pbt1 %>% group_by(basin) %>% summarise_all(funs(sum))

## actual sample size for PBT only by basin
pbt2<-subset(new.group,rear=="H",select= -c(group_assignment,stock_assignment,rear))
 pbt.only.freq = pbt2 %>% group_by(basin) %>% summarise_all(funs(sum))

## adjusted sample size for PBT only by basin
pbt3<-subset(new.ests,rear=="H",select = -c(group_assignment,stock_assignment,rear))
 pbt.only.adjust = pbt3 %>% group_by(basin) %>% summarise_all(funs(sum))

# Write PBT only by basin results to output file

pbt.res1<-merge(pbt.only.point,pbt.only.freq)
 pbt.res2<-merge(pbt.res1,pbt.only.adjust)

 setnames(pbt.res2, old= c(1,2,3,4), new = c('basin','proportion','actual','adjusted'))

 all.results.pbt.only.by.basin<-merge(pbt.res2,pbt.basin.lci.uci)

## calculate CI's, bootstrap mean, st dev, cv for stocks identified with
# GSI (rear="U") by basin. These basin results exclude PBT assigned fish

gsi.only<-subset(stock.rear.groups,rear=="U",select = -c(group_assignment,stock_assignment,rear))

gsi.only.basin = gsi.only %>% group_by(basin) %>% summarise_all(funs(sum))

gsi0<-subset(gsi.only.basin, select = -c(basin))

gsi.basin.lci.uci<- data.frame(basin=gsi.only.basin$basin,lci=apply(gsi0,1,quantile,(1-ci)/2),uci=apply(gsi0,1,quantile,((1-ci)/2)+ci), mean=apply(gsi0,1,mean),st.dev=apply(gsi0,1,sd))

gsi.basin.lci.uci$cv<-(gsi.basin.lci.uci$st.dev/gsi.basin.lci.uci$mean)*100

## point estimates for GSI only by basin
gsi1<-subset(point.stock.rear.groups,rear=="U",select = -c(group_assignment,stock_assignment,rear))
 gsi.only.point = gsi1 %>% group_by(basin) %>% summarise_all(funs(sum))

## actual sample size for GSI only by basin
gsi2<-subset(new.group,rear=="U",select= -c(group_assignment,stock_assignment,rear))
 gsi.only.freq = gsi2 %>% group_by(basin) %>% summarise_all(funs(sum))

## adjusted sample size for GSI only by basin
gsi3<-subset(new.ests,rear=="U",select = -c(group_assignment,stock_assignment,rear))
 gsi.only.adjust = gsi3 %>% group_by(basin) %>% summarise_all(funs(sum))

# Write GSI only by basin results to output file

gsi.res1<-merge(gsi.only.point,gsi.only.freq)
 gsi.res2<-merge(gsi.res1,gsi.only.adjust)

 setnames(gsi.res2, old= c(1,2,3,4), new = c('basin','proportion','actual','adjusted'))

 all.results.gsi.only.by.basin<-merge(gsi.res2,gsi.basin.lci.uci)

# Write the table of proportions of each bootstrap iteration to a .csv file #

# if further analysis/summaries are needed. The prop.table was used to get
# Cis for group_assignments. Stock, rear, and basin CIs were found by summing # the hatchery release groups (for example all Dworshak groups
#  for stock) in each iteration.

######  write results to csv files ###

### summary stats with point estimate, actual group sample size, adjusted
# group sample size used for the point estimates, Lower CI, Upper CI, Mean,
# CV, Std Dev. To name files program uses the fishery type (output) that was
# #set at beginning of program
###########################################################################

write.csv(prop.table, file = paste("Resampled group proportions_",output,sep="_"))

write.csv(results.group, file = paste("Results by Group",output,sep="_"))

write.csv(all.results.stock, file = paste("Results by Stock_",output,sep="_"))

write.csv(all.results.rear, file = paste("Results by Rear_",output,sep="_"))

write.csv(all.results.basin, file = paste("Results by Basin All Samples_",output,sep="_"))

write.csv(all.results.pbt.only.by.basin, file = paste("Results by Basin PBT only",output,sep="_"))

write.csv(all.results.gsi.only.by.basin, file = paste("Results by Basin GSI only",output,sep="_"))

end.time<-Sys.time()
 runtime<-end.time-start.time
   runtime

######### END OF PROGRAM  #####################


library(shiny)
library(datasets)
library(topicmodels)

## load data

## todo: generalize and clean up

data = list()

path = "/Users/mnelimar/Dropbox/projects/2016-topicmodelkritiikki/papereittain"
files = list.files( path )

for( f in files ) {
    p <- paste( path , f, sep = '/' )
    load( p )
    data[ model@k ] <- model
}

## start server
shinyServer(function(input, output) {

  model <- reactive({
    data[[ input$k ]]
  })

  wordcount <- reactive({
    input$n
  })

  output$view <- renderTable({
    terms( model(), wordcount() )
  })

})


#install.packages("tidyverse")
library(Rmisc)
library(ggplot2)
library(dplyr)
args = commandArgs(trailingOnly=TRUE)

# test if there is at least one argument: if not, return an error
if (length(args)==0) {
        stop("At least one argument must be supplied (input file).n", call.=FALSE)
} else if (length(args)==1) {
        # default output file
        args[2] = "out.png"
}

nome = ( paste(args, collapse = " "))

setwd("~/Project_n/Across-Modalities/data/processed/")

df <- read.csv(file = args[1])

tgc <- df %>%
  group_by(Real.Bin,Modality,Exposures) %>%
  summarise(median = median(Predicted.Bin), percentil25 = quantile(Predicted.Bin, 0.25), percentil75 = quantile(Predicted.Bin, 0.75))

p<- ggplot(tgc, aes(x=Real.Bin, y=Predicted.Bin, group=Exposures, color=Modality)) +
     facet_wrap(c("Exposures","Modality")) +
     scale_x_continuous(breaks=c(1,2,3,4,5,6)) +
     scale_y_continuous(breaks =c(1,2,3,4,5,6)) +
     geom_line() +
     geom_point()+
     theme_classic()+
     geom_errorbar(aes(ymin=percentil25, ymax=percentil75), width=.2, position=position_dodge(0.05))

p <- p + geom_point(data=df,aes(x=Real.Bin, y=Predicted.Bin, group=Exposures, color=Modality) ) + facet_wrap(c("Exposures","Modality"))

setwd("~/Project_n/Across-Modalities/reports/figures/")

png(args[2], width = 1000, height =1000)
plot(p)
dev.off()


# This analysis uses on a number of packages that are under active development
# and changing rapidly as the pandemic progresses. The specific versions of the
# LSHTM modelling packages we used can be installed from GitHub using the
# folowing code. The remotes package used to install them is available on CRAN.

remotes::install_github("epiforecasts/scoringutils@6efcbf8")
remotes::install_github("epiforecasts/EpiSoon@67ae487")
remotes::install_github("epiforecasts/EpiNow@3236137")


#!/usr/bin/Rscript

# File: scrape30min.r
# stefan contractor, mat lipson and james goldie
# Description:
# This is a script run every half hour to scrape current observations
# It is run through crontab, editable with: crontab

library(dplyr)
library(readr)
library(purrr)
library(lubridate)
library(xml2)
library(RJSONIO)

message(Sys.time(), " Looking for new observations...")

if (Sys.info()["user"] == "ubuntu")
{
  # running on the server
  fullpath <- "/srv/isithotrightnow/"
} else {
  # testing locally
  fullpath <- "./"
}
bom_xml_path <- "ftp://ftp.bom.gov.au/anon/gen/fwo/"

# get station id list from locations.json
#and use it to construct a station filter
station_ids <-
  fromJSON(paste0(fullpath, "www/locations.json")) %>%
  map(~ pluck(., "id")) %>%
  unlist()
xpath_filter <-
  paste0("@bom-id = '", station_ids, "'") %>%
  paste(collapse = " or ")

obs_new <-
  map_dfr(
    # for each state, we're going to...
    c("D", "N", "Q", "S", "T", "V", "W"),
    # download the file and select the matching stations
    ~ read_xml(paste0(bom_xml_path, "ID", ., "60920.xml")) %>%
    xml_find_all(paste0("//station[", xpath_filter, "]")) %>%
    # build a data frame with the info we want...
    {
      data_frame(
        station_id = xml_attr(., "bom-id"),
        tz = xml_attr(., "tz"),
        lat = xml_attr(., "lat"),
        lon = xml_attr(., "lon"),
        tmax =
          xml_find_first(., ".//element[@type='maximum_air_temperature']") %>%
          xml_text() %>%
          as.numeric(),
        tmax_dt =
          xml_find_first(., ".//element[@type='maximum_air_temperature']") %>%
          xml_attr("time-local"),
        tmin =
          xml_find_first(., ".//element[@type='minimum_air_temperature']") %>%
          xml_text() %>%
          as.numeric(),
        tmin_dt =
          xml_find_first(., ".//element[@type='minimum_air_temperature']") %>%
          xml_attr("time-local"))
    }  %>%
    # convert the date-time strings
    rowwise() %>%
    mutate(
      tmax_dt = ymd_hms(tmax_dt, tz = tz),
      tmin_dt = ymd_hms(tmin_dt, tz = tz)) %>%
    ungroup())

  message(Sys.time(), " Downloaded and extracted new observations")

# just use these obs if we don't have existing ones
if (!file.exists(paste0(fullpath, "data/latest/latest-all.csv")))
{
  write_csv(obs_new, paste0(fullpath, "data/latest/latest-all.csv"))
  message(Sys.time(), " Wrote out first station observations")

} else {

  # but if we do have existing obs, we want whichever obs are greater
  # (for maxes) or lower (for mins) *within the last 24 hours*

  obs_old <-
    read_csv(
      paste0(fullpath, "data/latest/latest-all.csv"),
      col_types = cols(
        tmax = col_double(),
        tmin = col_double(),
        .default = col_character())) %>%
    rowwise() %>%
    # note that datetimes are written out in utc. we can leave them this way
    # for the time checking maths :)
    mutate(
      tmax_dt = ymd_hms(tmax_dt),
      tmin_dt = ymd_hms(tmin_dt)) %>%
    ungroup() %>%
    rename(
      tmax_old = tmax,
      tmax_old_dt = tmax_dt,
      tmin_old = tmin,
      tmin_old_dt = tmin_dt)

  # join the old and new obs together, select the better obs,
  # drop the others and write it out
  full_join(obs_new, obs_old) %>%
  # get today's local midnight in utc so that we can drop old obs from yesterday
  rowwise() %>%
  mutate(
    today_start_utc =
      Sys.time() %>%
      with_tz(tz) %>%
      date() %>%
      paste("00:00:00") %>%
      ymd_hms(tz = tz) %>%
      with_tz('UTC')) %>%
  ungroup() %>%
  mutate(
    # first, select new obs if they're more extreme than the previous ones
    # *and* within the 24 hour window....
    tmax_selected = if_else(
      tmax >= tmax_old | tmax_old_dt < today_start_utc, tmax, tmax_old),
    tmax_selected_dt = if_else(
      tmax >= tmax_old | tmax_old_dt < today_start_utc, tmax_dt, tmax_old_dt),
    tmin_selected = if_else(
      tmin <= tmin_old | tmin_old_dt < today_start_utc, tmin, tmin_old),
    tmin_selected_dt = if_else(
      tmin <= tmin_old | tmin_old_dt < today_start_utc, tmin_dt, tmin_old_dt),
    # then, backfill any nas
    tmax_selected = coalesce(tmax_selected, tmax, tmax_old),
    tmax_selected_dt = coalesce(tmax_selected_dt, tmax_dt, tmax_old_dt),
    tmin_selected = coalesce(tmin_selected, tmin, tmin_old),
    tmin_selected_dt = coalesce(tmin_selected_dt, tmin_dt, tmin_old_dt)) %>%
  print() %>% # for debugging!
  select(
    station_id, tz, lat, lon,
    tmax = tmax_selected, tmax_dt = tmax_selected_dt,
    tmin = tmin_selected, tmin_dt = tmin_selected_dt) %>%
  print() %>%
  write_csv(paste0(fullpath, "data/latest/latest-all.csv"))

  message(Sys.time(), " Wrote out new station observations")
}


require_relative 'spec_helper'

RSpec.describe PDF::Core do
  context 'Decimal rounding' do
    it 'rounds floating point numbers to four decimal places' do
      expect(described_class.real(1.23456789)).to eq 1.2346
    end

    it 'is able to create a PDF parameter list of rounded decimals' do
      expect(described_class.real_params([1, 2.34567, Math::PI]))
        .to eq '1.0 2.3457 3.1416'
    end
  end
end


#------------------------------------------------------------------------------
#	Names of models supported by lsmeans.
#------------------------------------------------------------------------------
LSMEANS_COMPATIBLE_MODELS <- c(
	"glm", glmer = "glmerMod", "lm", "lme", lmer = "lmerMod",
	"MCMCglmm"
)

LSMEANS_INCOMPATIBLE_MODELS <- c(
	cforest = "RandomForest", ctree = "BinaryTree", "gam", "gamm", "gbm",
	"glmmadmb", "glmmML", "randomForest", "ranger", "rpart", "svm", "tree"
)

#------------------------------------------------------------------------------
#'	(Internal) A reference class calculates partial relationship.
#'
#'	@field data
#'		data.frame to keep calculated partial relationship data.
#'
#'	@field data.split
#'		a list having splitted data.frame for each group specified in x.names.
#'
#'	@field settings
#'		class settings.
#'
#'	@include pp.settings.r
#------------------------------------------------------------------------------
partial.relationship <- setRefClass(
	"partial.relationship",
	field = list(
		data = "data.frame",
		data.split = "list",
		settings = "pp.settings"
	)
)

#------------------------------------------------------------------------------
partial.relationship$methods(
	initialize = function(settings) {
		"
		Initialize class and calculate partial.relationship data.

		\\describe{
			\\item{settings}{pp.settings object having function settings.}
		}
		"
		# Safe-guard for internal processing of reference class.
		if (missing(settings)) {
			return()
		}
		.self$settings <- settings
		# Calculate partial relationship data.
		if (!any(class(settings$model) %in% LSMEANS_INCOMPATIBLE_MODELS)) {
			.self$data <- .self$partial.relationship.lsmeans()
		} else {
			.self$data <- .self$partial.relationship.internal()
		}
		# Split data.
		if (length(settings$x.names.factor) == 0) {
			.self$data.split <- list(all = .self$data)
		} else {
			.self$data.split <- split(
				.self$data, .self$data[settings$x.names.factor],
				sep = settings$sep
			)
		}
		# Assign data to settings object.
		settings$set.relationship(.self)
	}
)

#------------------------------------------------------------------------------
partial.relationship$methods(
	partial.relationship.lsmeans = function() {
		"
		Calculate partial regression lines and intervals.

		This function calculates data for regression lines and intervals using
		\\code{\\link[emmeans]{lsmeans}} function and returns a data.frame.
		"
		# calculate prediction.
		at <- c(.self$settings$numeric.sequences, .self$settings$factor.levels)
		rg <- ref_grid(
			.self$settings$model, at, data = .self$settings$data,
			type = .self$settings$type
		)
		lsm <- .self$summarize.ref.grid(rg)
		# Remove predictions with out-ranged explanatory variable for each group.
		lsm <- .self$filter.result(lsm)
		return(as.data.frame(lsm))
	}
)

#------------------------------------------------------------------------------
partial.relationship$methods(
	summarize.ref.grid.without.mcmc = function(lsm) {
	  "Calculate predictions and intervals using lsmeans without mcmc."
		result <- summary(lsm, level = .self$settings$interval.levels)
		colnames(result) <- gsub(
			"^lsmean$|^response$|^prob$|^rate$", "fit", colnames(result)
		)
		colnames(result) <- gsub(
			"^lower.CL$|^asymp.LCL$", "lower", colnames(result)
		)
		colnames(result) <- gsub(
			"^upper.CL$|^asymp.UCL$", "upper", colnames(result)
		)
		return(result)
	}
)

#------------------------------------------------------------------------------
partial.relationship$methods(
	summarize.ref.grid.with.mcmc = function(lsm) {
	  "Calculate predictions and intervals using lsmeans with mcmc."
		lsm.mcmc <- as.mcmc(lsm)
		m <- apply(lsm.mcmc, 2, mean)
		interval.levels <- c(
			.self$settings$interval.levels, 1 - .self$settings$interval.levels
		)
		q <- t(apply(lsm.mcmc, 2, quantile, prob = sort(interval.levels)))
		colnames(q) <- c("lower", "upper")
		result <- suppressMessages(
			summary(lsm, level = .self$settings$interval.levels)
		)
		result <- result[.self$settings$x.names]
		result$fit <- m
		result <- cbind(result, q)
		return(result)
	}
)

#------------------------------------------------------------------------------
partial.relationship$methods(
	summarize.ref.grid = function(rg) {
	  "Calculate predictions and intervals using lsmeans."
	  lsm <- lsmeans(rg, .self$settings$x.names)
		if (length(lsm@post.beta) == 1 & all(is.na(lsm@post.beta))) {
			return(.self$summarize.ref.grid.without.mcmc(lsm))
		}
		coda.available <- require(coda)
		if (coda.available) {
			return(.self$summarize.ref.grid.with.mcmc(lsm))
		}
		return(.self$summarize.ref.grid.without.mcmc(lsm))
	}
)

#------------------------------------------------------------------------------
partial.relationship$methods(
	predict.stats = function(
		newdata, predict.fun, new.value.grid, index, levels, type
	) {
		"
		Calculate prediction in cluster.

		\\describe{
			\\item{\\code{newdata}}{newdata for prediction.}
			\\item{\\code{predict.fun}}{predict function.}
			\\item{\\code{new.value.grid}}{
				a data.frame having all combination of focal values of
				partial relationship grid.
			}
			\\item{\\code{index}}{
				row index of \\code{new.value.grid} where predicted values
				are calculated.
			}
			\\item{\\code{levels}}{levels of quantiles.}
		}
		"
		on.exit(gc())
		# Make data for prediction.
		replace.values <- new.value.grid[index, ]
		param.names <- names(new.value.grid)
		newdata[param.names] <- replace.values
		# Make prediction.
		prediction <- predict.fun(newdata = newdata, type = type)
		if (type == "prob") {
			prediction$fit <- prediction$fit[, .self$settings$positive.class]
		}
		quantiles <- quantile(prediction$fit, probs = levels, na.rm = TRUE)
		result <- c(fit = mean(prediction$fit), quantiles, replace.values)
		names(result) <- c("fit", "lower", "upper", param.names)
		result <- as.data.frame(as.list(result))
		return(result)
	}
)

#------------------------------------------------------------------------------
partial.relationship$methods(
	partial.relationship.internal = function() {
		"
		Calculate partial relationship data internally.
		Mainly used for machine learning methods.
		"
		# prepare combinations of x variables.
		grid <- do.call(
			expand.grid,
			c(.self$settings$numeric.sequences, .self$settings$factor.levels)
		)
		grid <- .self$filter.result(grid)
		# Run calculation.
		result <- .self$calculate.relationship(grid)
		return(result)
	}
)

#------------------------------------------------------------------------------
partial.relationship$methods(
	calculate.relationship = function(grid) {
		"
		Calculate partial relationship.
		\\describe{
			\\item{\\code{grid}}{
				explanatory variables where predicted values are calculated.
			}
		}
		"
		result <- settings$cluster.apply(
			X = 1:nrow(grid), FUN = .self$predict.stats,
			newdata = .self$settings$data,
			predict.fun = .self$settings$adapter$predict,
			new.value.grid = grid, levels = .self$settings$interval.levels,
			type = ifelse(.self$settings$type == "prob", "prob", "link")
		)
		result <- do.call(rbind, result)
		if (.self$settings$type == "response") {
			for (i in c("fit", "lower", "upper")) {
				result[[i]] <- .self$settings$adapter$linkinv(result[[i]])
			}
		}
		return(result)
	}
)

#------------------------------------------------------------------------------
partial.relationship$methods(
	filter.result = function(prediction) {
		"
		Remove out-ranged values from result of lsmeans.

		This internal function removes predicted values those explanatory
		variable is out of range of original data used for modeling for each
		group and returns a resultant data.frame.

		\\describe{
			\\item{prediction}{result of lsmeans.}
		}
		"
		if (
			length(.self$settings$factor.levels) == 0
			| .self$settings$extrapolate
		) {
			return(prediction)
		}
		# Get list of unique factors.
		factors <- expand.grid(.self$settings$factor.levels)
		# Split data and prediction for each factor group.
		sep = .self$settings$sep
		pred.split <- split(prediction, prediction[names(factors)], sep = sep)
		orig.data.split <- split(
			.self$settings$data, .self$settings$data[names(factors)], sep = sep
		)
		# Filter out out-ranged numeric values.
		result <- list()
		for (i in 1:nrow(factors)) {
			split.name <- combine.columns(
				as.data.frame(factors[i, ]), sep = sep
			)
			current.pred <- pred.split[[split.name]]
			current.data <- orig.data.split[[split.name]]
			for (numeric.name in .self$settings$x.names.numeric) {
				var.range <- range(current.data[[numeric.name]])
				filter <- current.pred[[numeric.name]] >= var.range[1]
				filter <- filter & current.pred[[numeric.name]] <= var.range[2]
				current.pred <- current.pred[filter, ]
			}
			result[[split.name]] <- current.pred
		}
		result <- do.call(rbind, result)
		return(result)
	}
)


##SNOPSIS

#Qtl analysis based on rqtl.

##AUTHOR
## Isaak Y Tecle (iyt2@cornell.edu)

options(echo = FALSE)

library(qtl)

allargs <- commandArgs()

infile   <- grep("infile_list", allargs, value=TRUE)
outfile  <- grep("outfile_list", allargs, value=TRUE)

infile   <- scan(infile, what="character")
statfile <- grep("stat", infile, value=TRUE)

##### stat files
statfiles <- scan(statfile, what="character")

###### QTL mapping method ############
qtlmethodfile <- grep("stat_qtl_method", statfiles, value=TRUE)
qtlmethod <- scan(qtlmethodfile, what="character", sep="\n")

if (qtlmethod == "Maximum Likelihood") {
  qtlmethod <- c("em")
} else if (qtlmethod == "Haley-Knott Regression") {
  qtlmethod <- c("hk")
} else if (qtlmethod == "Multiple Imputation") {
  qtlmethod <- c("imp")
} else if (qtlmethod == "Marker Regression") {
  qtlmethod <- c("mr")
}

###### QTL model ############
qtlmodelfile <- grep("stat_qtl_model",  statfiles, value=TRUE)
qtlmodel <- scan(qtlmodelfile, what="character", sep="\n")

if (qtlmodel == "Single-QTL Scan") {
  qtlmodel <- c("scanone")
} else if  (qtlmodel == "Two-QTL Scan") {
  qtlmodel<-c("scantwo")
}

###### permutation############
userpermufile  <- grep("stat_permu_test", statfiles, value=TRUE)
userpermuvalue <- scan(userpermufile, what="numeric", dec= ".", sep="\n")

if (userpermuvalue == "None") {
  userpermuvalue<-c(0)
}

userpermuvalue <- as.numeric(userpermuvalue)

#####for test only
#userpermuvalue<-c(100)
#####

######genome step size############
stepsizefile <- grep("stat_step_size",  statfiles, value=TRUE)

stepsize <- scan(stepsizefile, what="numeric", dec = ".", sep="\n")

if (qtlmethod == 'mr') {
    stepsize <- c(0)
} else if (qtlmethod != 'mr' & stepsize == "zero") {
      stepsize <- c(0)
  }

stepsize <- as.numeric(stepsize)

######genotype calculation method############
genoprobmethodfile <- grep("stat_prob_method", statfiles, value=TRUE)

genoprobmethod <- scan(genoprobmethodfile, what="character", dec=".", sep="\n")

########No. of draws for sim.geno method###########
drawsnofile <- c()
drawsno <- c()
if (qtlmethod == 'imp') {
    if (is.null(grep("stat_no_draws", statfiles))==FALSE) {
        drawsnofile <- grep("stat_no_draws", statfiles, value=TRUE)
    }

    if (is.null(drawsnofile)==FALSE) {
        drawsno <- scan(drawsnofile, what="numeric", dec = ".", sep="\n")
        drawsno <- as.numeric(drawsno)
      }
  }
########significance level for genotype
#######probablity calculation
genoproblevelfile <- grep("stat_prob_level", statfiles, value=TRUE)
genoproblevel     <- scan(genoproblevelfile, what="numeric", dec = ".", sep="\n")

if (qtlmethod == 'mr') {
    if (is.logical(genoproblevel) == FALSE) {
        genoproblevel <- c(0)
    }

    if (is.logical(genoprobmethod) ==FALSE) {
        genoprobmethod <- c('Calculate')
      }
  }

genoproblevel <- as.numeric(genoproblevel)

########significance level for permutation test
permuproblevelfile <- grep("stat_permu_level", statfiles, value=TRUE)

permuproblevel <- scan(permuproblevelfile, what="numeric", dec = ".", sep="\n")

permuproblevel <- as.numeric(permuproblevel)

#########
cvtermfile <- grep("cvterm", infile, value=TRUE)

popidfile <- grep("popid", infile, value=TRUE)

genodata <- grep("genodata", infile, value=TRUE)

phenodata <- grep("phenodata", infile, value=TRUE)

permufile <- grep("permu", infile, value=TRUE)

crossfile <- grep("cross", infile, value=TRUE)

popid <- scan(popidfile, what="integer", sep="\n")

cross <- scan(crossfile,what="character", sep="\n")

popdata<-c()

if (cross == "f2")
{
  popdata <- read.cross("csvs",
                       genfile=genodata,
                       phefile=phenodata,
                       na.strings=c("NA", "-"),
                       genotypes=c("1", "2", "3", "4", "5"),
                       )

  popdata <-jittermap(popdata)
} else if (cross == "bc" | cross == "rilsib" | cross == "rilself") {

  popdata <- read.cross("csvs",
                       genfile=genodata,
                       phefile=phenodata,
                       na.strings=c("NA", "-"),
                       genotypes=c("1", "2"),
                       )

  popdata<-jittermap(popdata)
}

if (cross == "rilself") {
    popdata<-convert2riself(popdata)
} else if (cross == "rilsib") {
    popdata<-convert2risib(popdata)
}

#calculates the qtl genotype probablity at
#the specififed step size and probability level
genotypetype <- c()

if (genoprobmethod == "Calculate") {
    popdata <- calc.genoprob(popdata,
                           step=stepsize,
                           error.prob=genoproblevel
                           )
    genotypetype<-c('prob')
} else if (genoprobmethod == "Simulate") {
    popdata <- sim.geno(popdata,
                      n.draws=drawsno,
                      step=stepsize,
                      error.prob=genoproblevel,
                      stepwidth="fixed"
                        )

    genotypetype <- c('draws')
}

cvterm <- scan(cvtermfile, what="character") #reads the cvterm

cv <- find.pheno(popdata, cvterm)#returns the col no. of the cvterm

permuvalues <- scan(permufile, what="character")

permuvalue1 <- permuvalues[1]
permuvalue2 <- permuvalues[2]
permu <- c()

if (is.logical(permuvalue1) == FALSE) {
  if (qtlmodel == "scanone") {
    if (userpermuvalue == 0 ) {
      popdataperm <- scanone(popdata,
                             pheno.col=cv,
                             model="normal",
                             method=qtlmethod
                             )

    } else if (userpermuvalue != 0) {
        popdataperm <- scanone(popdata,
                               pheno.col=cv,
                               model="normal",
                               n.perm = userpermuvalue,
                               method=qtlmethod
                               )

        permu <- summary(popdataperm, alpha=permuproblevel)
    }
  } else if (qtlmethod != "mr") {
    if (qtlmodel == "scantwo") {
      if (userpermuvalue == 0 ) {
        popdataperm <- scantwo(popdata,
                               pheno.col=cv,
                               model="normal",
                               method=qtlmethod
                               )
      } else if (userpermuvalue != 0) {
          popdataperm <- scantwo(popdata,
                                 pheno.col=cv,
                                 model="normal",
                                 n.perm=userpermuvalue,
                                 method=qtlmethod
                                 )

        permu <- summary(popdataperm, alpha=permuproblevel)

      }
    }
  }
}

##########set the LOD cut-off for singificant qtls ##############
LodThreshold <- c()

if(is.null(permu) == FALSE) {
  LodThreshold <- permu[1,1]
}
##########QTL EFFECTS ##############

chrlist <- c("chr1")

for (no in 2:12) {
    chr <- paste("chr", no, sep="")

    chrlist <- append(chrlist, chr)
}

chrdata <- paste(cvterm, popid, "chr1", sep="_")

chrtest <- c("chr1")

for (ch in chrlist) {
  if (ch=="chr1") {
    chrdata <- paste(cvterm, popid, ch, sep="_")
  } else {
    n <- paste(cvterm, popid, ch, sep="_")
    chrdata <- append(chrdata, n)
  }
}

chrno <- 1

datasummary <- c()
confidenceints <- c()
lodconfidenceints <- c()
QtlChrs <- c()
QtlPositions <- c()
QtlLods <- c()

for (i in chrdata) {
  filedata <- paste(cvterm, popid, chrno, sep="_")
  filedata <- paste(filedata,"txt",sep=".")

  i <- scanone(popdata,
               chr=chrno,
               pheno.col=cv,
               model = "normal",
               method= qtlmethod
               )

  position <- max(i,chr=chrno)

  p <- position[["pos"]]
  LodScore <- position[["lod"]]
  QtlChr <- levels(position[["chr"]])

      if ( is.null(LodThreshold)==FALSE ) {
          if (LodScore >=LodThreshold ) {
              QtlChrs <- append(QtlChrs, QtlChr)
              QtlLods <- append(QtlLods, LodScore)
              QtlPositions <- append(QtlPositions, round(p, 0))
            }
        }

  peakmarker <- find.marker(popdata, chr=chrno, pos=p)

  lodpeakmarker <- i[peakmarker, ]

  lodconfidenceint <- bayesint(i, chr=chrno, prob=0.95, expandtomarkers=TRUE)

  if (is.na(lodconfidenceint[peakmarker, ])){
      lodconfidenceint <- rbind(lodconfidenceint, lodpeakmarker)
    }

  peakmarker <- c(chrno, peakmarker)

  if (chrno==1) {
    datasummary <- i
    peakmarkers <- peakmarker
    lodconfidenceints <- lodconfidenceint
  }

  if (chrno > 1 ) {
      datasummary <- rbind(datasummary, i)
      peakmarkers <- rbind(peakmarkers, peakmarker)
      lodconfidenceints <- rbind(lodconfidenceints, lodconfidenceint)
  }

chrno <- chrno + 1;

}

##########QTL EFFECTS ##############
 ResultDrop <- c()
 ResultFull <- c()
 Effects <- c()

if (is.null(LodThreshold) == FALSE) {
    if ( max(QtlLods) >= LodThreshold ) {
        QtlObj <- makeqtl(popdata,
                          QtlChrs,
                          QtlPositions,
                          what=genotypetype
                          )

        QtlsNo <- length(QtlPositions)
        Eq <- c("y~")

        for (i in 1:QtlsNo) {
                q <- paste("Q", i, sep="")

                if (i==1) {
                    Eq <- paste(Eq, q, sep="")
                  } else if (i>1) {
                      Eq <- paste(Eq, q, sep="*")
                  }
              }

        QtlEffects <- try(fitqtl(popdata,
                                 pheno.col=cv,
                                 QtlObj,
                                 formula=Eq,
                                 method="hk",
                                 get.ests=TRUE
                                 )
                          )

        if(class(QtlEffects) != 'try-error') {

                ResultModel <- attr(QtlEffects, "formula")
                Effects     <- QtlEffects$ests$ests
                QtlLodAnova <- QtlEffects$lod
                ResultFull  <- QtlEffects$result.full
                ResultDrop  <- QtlEffects$result.drop

                if (is.numeric(Effects)) {
                    Effects <- round(Effects, 2)
                }

                if (is.numeric(ResultFull)) {
                    ResultFull <- round(ResultFull,2)
                }

                if (is.numeric(ResultDrop)) {
                    ResultDrop<-round(ResultDrop, 2)
                }
            }
    }
}

##########creating vectors for the outfiles##############

outfiles <- scan(file=outfile, what="character")

qtlfile           <- grep("qtl_summary", outfiles, value=TRUE)
peakmarkersfile   <- grep("peak_marker", outfiles, value=TRUE)
confidencelodfile <- grep("confidence", outfiles, value=TRUE)
QtlEffectsFile    <- grep("qtl_effects", outfiles, value=TRUE)
VariationFile     <- grep("explained_variation", outfiles, value=TRUE)

##### writing outputs to their respective files

write.table(datasummary,
            file=qtlfile,
            sep="\t",
            col.names=NA,
            quote=FALSE,
            append=FALSE
            )

write.table(peakmarkers,
            file=peakmarkersfile,
            sep="\t",
            col.names=NA,
            quote=FALSE,
            append=FALSE
            )

write.table(lodconfidenceints,
            file=confidencelodfile,
            sep="\t",
            col.names=NA,
            quote=FALSE,
            append=FALSE
            )

if (is.null(ResultDrop)==FALSE) {
  write.table(ResultDrop,
              file=VariationFile,
              sep="\t",
              col.names=NA,
              quote=FALSE,
              append=FALSE
              )
} else {
  if (is.null(ResultFull)==FALSE) {
      write.table(ResultFull,
              file=VariationFile,
              sep="\t",
              col.names=NA,
              quote=FALSE,
              append=FALSE
              )
    }
}

write.table(Effects,
            file=QtlEffectsFile,
            sep="\t",
            col.names=NA,
            quote=FALSE,
            append=FALSE
            )

write.table(permu,
            file=permufile,
            sep="\t",
            col.names=NA,
            quote=FALSE,
            append=FALSE
                )

q(runLast = FALSE)


require(XML)
Cfile <- file("commands", "w")

cmd1 <- paste("cp config.xml config.old")
system(cmd1)

##output_file_prefix <- format(Sys.time(), "%Y%m%d%H%M")
output_file_prefix <- "bm1"
output_path = "out"
rep = 0

output_dir = "out"
cell_position_file = "cellPos.txt"
Nstep = 1600
dt = 0.01
eta = 20
two_population_model = 0
## q0= 1.5
## a = 1.16
## b = 0.86
q0= 1.15
a = 1.0
b = 1.0
a_braf = 0.5
b_braf = 0.5
braf_mosaic_percentage = 0.0
mu = 0.01
stretching_force = 0.0
H_rate = 0.004
flag_output_cell = 1
flag_output_force = 0
flag_record_final_state = 0

##stretching_force_list <- c(1, 3, 7, 10, 14, 16)
##for ( stretching_force in stretching_force_list )
##for ( stretching_force in c(seq(15, 15, length.out=10), seq(10, 10, length.out=10) ))
##for ( i in seq(10) )
{
    ##stretching_force = 4
    rep = rep + 1
    cat("\n ***********run********* ", rep, "\n")
    FolderName <- paste("case_", output_file_prefix, "_", as.character(rep), sep='')
    dir.create(FolderName)

    ## The following part is to produce "config.xml"
    d <- xmlTreeParse("config.xml")
    r <- xmlRoot(d)
    xmlValue(r[["output_dir"]]) <- output_dir
    xmlValue(r[["cell_position_file"]]) <- cell_position_file
    xmlValue(r[["Nstep"]]) <- Nstep
    xmlValue(r[["dt"]]) <- dt
    xmlValue(r[["eta"]]) <- eta
    xmlValue(r[["two_population_model"]]) <- two_population_model
    xmlValue(r[["q0"]]) <- q0
    xmlValue(r[["a"]]) <- a
    xmlValue(r[["b"]]) <- b
    xmlValue(r[["a_braf"]]) <- a_braf
    xmlValue(r[["b_braf"]]) <- b_braf
    xmlValue(r[["braf_mosaic_percentage"]]) <- braf_mosaic_percentage
    xmlValue(r[["mu"]]) <- mu
    xmlValue(r[["stretching_force"]]) <- stretching_force
    xmlValue(r[["H_rate"]]) <- H_rate
    xmlValue(r[["flag_output_cell"]]) <- flag_output_cell
    xmlValue(r[["flag_output_force"]]) <- flag_output_force
    xmlValue(r[["flag_record_final_state"]]) <- flag_record_final_state
    saveXML(r, "config.xml")

    ## Copy the seqfile.txt into folder
    cmd2 <- paste("cp config.xml", FolderName)
    cmd3 <- paste("mkdir -p ", FolderName, "/out", sep='')
    cmd4 <- paste("cp PhysModel", FolderName)
    cmd5 <- paste("cp cellPos.txt", FolderName)
    system(cmd2)
    system(cmd3)
    system(cmd4)
    system(cmd5)

    ##rtime <- runif(1, 20, 200)
    ##runcmd <- paste("sleep ", rtime, "; cd", FolderName, "; screen PhysModel; cd ..")

    ## screen, on PC
    runcmd <- paste("cd", FolderName, "; screen -d -m PhysModel; cd ..")
    ## runcmd <- paste("screen -d -m ", FolderName, "/PhysModel", sep='')

    ## ## bsub, on server
    ## runcmd <- paste("bsub ", FolderName, "/PhysModel -o output_", rep, sep='')
    ## runcmd <- paste("cd ", FolderName, "; bsub PhysModel -o output_", rep, "; cd ..", sep='')

    writeLines(runcmd, Cfile)

}

cmd1 <- paste("mv config.old config.xml")
system(cmd1)

close(Cfile)


#Author: Josh Roll
#Date: 9/2020
#Description: This script downloads Census data using R tools that access the data using an Application Programming Interface (API).  These data are then used in a number of analyses including:
#1. Social VUlnerability Index Analysis of Pedestrian injuries
#2. Statistical modeling of crash risk factors for pedestrians.
#The below code retreives data for tracts but would work for counties, urban areas, and block groups.

#Purpose:
#The purpose of retreiving these data is to document the tract level sociodemographic factors, along with traffic expsoure and built environmental factors, that are associated with pedestrian injuries.

#Load libraries
#-----------------------
	library(dplyr)
	library(scales)
	library(tigris)
	library(tidycensus)
	library(acs)
	library(tidyr)

	#install.packages("PUMSutils")

#Set environmental working conditions
#-----------------------------
  #Set working directory
  setwd("")

  #Set Census API Key - dont have a key?  Get one here: https://api.census.gov/data/key_signup.html
  Developer_Key <- ""

#Define custom scripts functions
#------------------------------
	#Function that simplifies loading .RData objects
	assignLoad <- function(filename){
       load(filename)
       get(ls()[ls() != "filename"])
    }

	#Function to rename selected census ACS variable
	rename_ACS_vars <- function(dat, geo){
		#Reform variables and select columns of interest
		#Rename data file
		Census.. <- dat
		#Create logic for geography level
		#County----
		if(geo == "County"){Census.. <- Census.. %>% mutate(County =  trimws(gsub(" County, Oregon","",NAME)))}
		#Urban Area----
		if(geo == "Urban Area"){Census.. <- Census.. %>% mutate(Urban_Area_Id = GEOID, Urban_Area =  Cluster_City)}
		#Zip Code----
		if(geo == "Zip Code"){Census.. <- Census.. %>% mutate(Zip_Code = GEOID)}
		#Tract----
		if(geo == "Tract"){Census.. <- Census.. %>% mutate(Tract = GEOID, County = trimws(gsub(" County","",sapply(strsplit(as.character(NAME), ","), function(x) x[[2]]))))}
		#Block group
		if(geo == "Block Group"){Census.. <- Census.. %>% mutate(Block_Group = GEOID, County = trimws(gsub(" County","",sapply(strsplit(as.character(NAME), ","), function(x) x[[3]]))))}

		#Rename all other elements
		Census..  <- Census.. %>% mutate(
			#Total Population
			#Population = B17001_001E,
			Population = B01003_001E,
			#Poverty
			Poverty = B17021_002E,
			#SNAP
			SNAP_Hh = B22010_002E,
			#Households eith 1 or more disabled persons
			Disability_Hh = B22010_003E + B22010_006E,
			#Limited English proficiency
			#Limited_English  = B16004_021E + B16004_022E + B16004_023E + B16004_043E + B16004_044E + B16004_045E + B16004_065E + B16004_066E + B16004_067E,
			Limited_English  = B16004_006E + B16004_007E +B16004_008E +B16004_011E +B16004_012E +B16004_013E +B16004_016E +B16004_017E +B16004_018E +B16004_021E +B16004_022E +B16004_023E +
				B16004_028E + B16004_029E +B16004_030E +B16004_033E +B16004_034E +B16004_035E +B16004_038E +B16004_039E +B16004_040E +B16004_043E +B16004_044E +B16004_045E +
				B16004_050E +B16004_051E +B16004_052E +B16004_055E +B16004_056E +B16004_057E +B16004_060E +B16004_061E +B16004_062E +B16004_065E +B16004_066E +B16004_067E,
			#Total Households
			Total_Hh = B22010_001E,
			#Race
			White = B02001_002E, Black = B02001_003E,	AIAN = B02001_004E, Asian = B02001_005E, NHPI = B02001_006E,
				Mult_Race = (B02001_007E + B02001_008E + B02001_009E + B02001_010E), Latino = B03002_012E,
				Bipoc = B02001_003E + B02001_004E + B02001_005E + B02001_006E + B02001_007E + B02001_008E + B02001_009E + B02001_010E,
			Other_Race = B02001_004E +  B02001_006E,
			#Income
			Median_Income = B19013_001E,
			#Age
			#Male
			Age_Under5_Male = B01001_003E, Age_5_9_Male = B01001_004E, Age_10_14_Male = B01001_005E, Age_15_17_Male = B01001_006E, Age_18_19_Male = B01001_007E, Age_20_Male = B01001_008E, Age_21_Male = B01001_009E,
			Age_22_24_Male = B01001_010E, Age_25_29_Male = B01001_011E, Age_30_34_Male = B01001_012E, Age_35_39_Male = B01001_013E, Age_40_44_Male  = B01001_014E, Age_45_49_Male = B01001_015E,
			Age_50_54_Male = B01001_016E,	Age_55_59_Male = B01001_017E, Age_60_61_Male = B01001_018E, Age_62_64_Male = B01001_019E, Age_65_66_Male = B01001_020E, Age_67_69_Male = B01001_021E,
			Age_70_74_Male = B01001_022E, 	Age_75_79_Male = B01001_023E, Age_80_84_Male = B01001_024E, Age_Over_84_Male = B01001_025E,
			#Female
			Age_Under5_Female = B01001_027E, Age_5_9_Female = B01001_028E, Age_10_14_Female = B01001_029E, Age_15_17_Female = B01001_030E, Age_18_19_Female = B01001_031E, Age_20_Female = B01001_032E, Age_21_Female = B01001_033E,
			Age_22_24_Female = B01001_034E, Age_25_29_Female = B01001_035E, Age_30_34_Female = B01001_036E, Age_35_39_Female = B01001_037E, Age_40_44_Female  = B01001_038E, Age_45_49_Female = B01001_039E,
			Age_50_54_Female = B01001_040E,	Age_55_59_Female = B01001_041E, Age_60_61_Female = B01001_042E, Age_62_64_Female = B01001_043E, Age_65_66_Female = B01001_044E, Age_67_69_Female = B01001_045E,
			Age_70_74_Female = B01001_046E, 	Age_75_79_Female = B01001_047E, Age_80_84_Female = B01001_048E, Age_Over_84_Female = B01001_049E,
			#Vehicle availability
			#Vehicle_0 = B08201_002E , Vehicle_1 = B08201_003E, Vehicle_2 = B08201_004E, Vehicle_3 = B08201_005E, Vehicle_4_Plus = B08201_006E, #THis wasnt working for block groups
			Vehicle_0 = B25044_003E + B25044_010E , Vehicle_1 = B25044_004E + B25044_011E, Vehicle_2 = B25044_005E + B25044_012E, Vehicle_3 = B25044_006E + B25044_013E,
				Vehicle_4_Plus = B25044_007E + B25044_014E +  B25044_008E +  B25044_015E,
			#Commute mode
			Jtw_Motor_Vehicle = B08301_002E, Jtw_Transit =  B08301_010E, Jtw_Bike = B08301_018E, Jtw_Walk = B08301_019E,
			Workers = B08301_001E,
			#Unemployment
			Labor_Force = B23025_002E, Unemployment = B23025_005E,
		)
		#Create household proportions]
		Census..  <- Census.. %>% mutate(SNAP_Hh_Prop = SNAP_Hh / Total_Hh, Disability_Hh_Prop = Disability_Hh / Total_Hh,
			Vehicle_0_Prop = Vehicle_0 / Total_Hh,  Vehicle_1_Prop = Vehicle_1 / Total_Hh,  Vehicle_2_Prop = Vehicle_2 / Total_Hh,  Vehicle_3_Prop = Vehicle_3 / Total_Hh,
			Vehicle_4_Plus_Prop = Vehicle_4_Plus / Total_Hh
		)
		#Add male + female populations
		Census.. <- Census..%>% mutate(Age_Under5 = Age_Under5_Male + Age_Under5_Female, Age_5_9 = Age_5_9_Male + Age_5_9_Female, Age_10_14 = Age_10_14_Male + Age_10_14_Female,
			Age_15_17 = Age_15_17_Male + Age_15_17_Female, Age_18_19 = Age_18_19_Male + Age_18_19_Female, Age_20 = Age_20_Male + Age_20_Female, Age_21 = Age_21_Male + Age_21_Female,
		Age_22_24 = Age_22_24_Male + Age_22_24_Female, Age_25_29 = Age_25_29_Male + Age_25_29_Female, Age_30_34 = Age_30_34_Male + Age_30_34_Female, Age_35_39 = Age_35_39_Male + Age_35_39_Female,
		Age_40_44  = Age_40_44_Male + Age_40_44_Female, Age_45_49 = Age_45_49_Male + Age_45_49_Female, Age_50_54 = Age_50_54_Male + Age_50_54_Female, Age_55_59 = Age_55_59_Male + Age_55_59_Female,
		Age_60_61 = Age_60_61_Male + Age_60_61_Female, Age_62_64 = Age_62_64_Male + Age_62_64_Female, Age_65_66 = Age_65_66_Male + Age_65_66_Female, Age_67_69 = Age_67_69_Male + Age_67_69_Female,
		Age_70_74 = Age_70_74_Male + Age_70_74_Female, 	Age_75_79 = Age_75_79_Male + Age_75_79_Female, Age_80_84 = Age_80_84_Male + Age_80_84_Female, Age_Over_84 = Age_Over_84_Male + Age_Over_84_Female)

		#Create cohorts
		Census.. <- Census..%>% mutate(Age_Under14 = Age_Under5 + Age_5_9 + Age_10_14, Age_Under19 = Age_Under5 + Age_5_9 + Age_10_14 + Age_15_17 + Age_18_19,
			Age_20_24 = Age_20 + Age_21 + Age_22_24, Age_25_34 = Age_25_29 + Age_30_34, Age_35_44 = Age_35_39 + Age_40_44, Age_45_54 = Age_45_49 + Age_50_54, Age_55_64 = Age_55_59 + Age_60_61 + Age_62_64,
			Age_Over_64 = Age_65_66 + Age_67_69 + Age_70_74 + Age_75_79 + Age_80_84 + Age_Over_84,
			#Male
			Age_Under14_Male = Age_Under5_Male + Age_5_9_Male + Age_10_14_Male, Age_Under19_Male = Age_Under5_Male + Age_5_9_Male + Age_10_14_Male + Age_15_17_Male + Age_18_19_Male,
			Age_20_24_Male = Age_20_Male + Age_21_Male + Age_22_24_Male, Age_25_34_Male = Age_25_29_Male + Age_30_34_Male, Age_35_44_Male = Age_35_39_Male + Age_40_44_Male, Age_45_54_Male = Age_45_49_Male + Age_50_54_Male,
			Age_55_64_Male = Age_55_59_Male + Age_60_61_Male + Age_62_64_Male, Age_Over_64_Male =
			Age_65_66_Male + Age_67_69_Male + Age_70_74_Male + Age_75_79_Male + Age_80_84_Male + Age_Over_84_Male,
			#Female
			Age_Under14_Female = Age_Under5_Female + Age_5_9_Female + Age_10_14_Female, Age_Under19_Female = Age_Under5_Female + Age_5_9_Female + Age_10_14_Female + Age_15_17_Female + Age_18_19_Female,
			Age_20_24_Female = Age_20_Female + Age_21_Female + Age_22_24_Female, Age_25_34_Female = Age_25_29_Female + Age_30_34_Female, Age_35_44_Female = Age_35_39_Female + Age_40_44_Female, Age_45_54_Female = Age_45_49_Female + Age_50_54_Female,
			Age_55_64_Female = Age_55_59_Female + Age_60_61_Female + Age_62_64_Female, Age_Over_64_Female =
			Age_65_66_Female + Age_67_69_Female + Age_70_74_Female + Age_75_79_Female + Age_80_84_Female + Age_Over_84_Female
		)

		#Create cohorts proportions
		Vars. <- c("Poverty","Limited_English","Age_Under5","Age_Under14_Male","Age_Under19_Male", "Age_20_24_Male","Age_25_34_Male","Age_35_44_Male","Age_45_54_Male",
			"Age_55_64_Male","Age_Over_64_Male","Age_Under14_Female","Age_Under19_Female", "Age_20_24_Female","Age_25_34_Female","Age_35_44_Female","Age_45_54_Female",
			"Age_55_64_Female","Age_Over_64_Female","Age_Under14", "Age_Under19", "Age_20_24","Age_25_34","Age_35_44","Age_45_54",
			"Age_55_64","Age_Over_64")
		for(var in Vars.){
			Census..[paste(var,"_Prop",sep="")] <- Census..[,var] / Census..$Population
		}

		#Create proportions
		Census.. <- Census..%>% mutate(White_Prop = White / Population, Black_Prop = Black / Population, AIAN_Prop = AIAN / Population,
			Asian_Prop = Asian / Population, NHPI_Prop = NHPI / Population, Mult_Race_Prop = Mult_Race / Population, Latino_Prop = Latino / Population, Bipoc_Prop = Bipoc / Population,
			Jtw_Motor_Vehicle_Prop = Jtw_Motor_Vehicle / Workers, Jtw_Transit_Prop = Jtw_Transit / Workers, Jtw_Bike_Prop = Jtw_Bike / Workers, Jtw_Walk_Prop = Jtw_Walk / Workers,
			Unemployment_Rate = Unemployment / Labor_Force
		)
		#Define the final selected variables
		#################################
		Select_Vars. <- c(
				"Population",
			"Poverty","Poverty_Prop","Limited_English",	"Limited_English_Prop",
			"SNAP_Hh","Disability_Hh","SNAP_Hh_Prop", "Disability_Hh_Prop",
			"White", "Black","AIAN","Asian","NHPI","Mult_Race","Latino","Bipoc",
			"White_Prop", "Black_Prop", "AIAN_Prop", "Asian_Prop", "NHPI_Prop", "Mult_Race_Prop", "Latino_Prop", "Bipoc_Prop",
			"Median_Income","Total_Hh",	"Age_Under5_Male","Age_5_9_Male","Age_10_14_Male","Age_15_17_Male","Age_18_19_Male","Age_20_Male","Age_21_Male",
			"Age_22_24_Male","Age_25_29_Male","Age_30_34_Male","Age_35_39_Male","Age_40_44_Male","Age_45_49_Male",
			"Age_50_54_Male","Age_55_59_Male","Age_60_61_Male","Age_62_64_Male","Age_65_66_Male","Age_67_69_Male",
			"Age_70_74_Male","Age_75_79_Male","Age_80_84_Male","Age_Over_84_Male",
			"Age_Under5_Female","Age_5_9_Female","Age_10_14_Female","Age_15_17_Female","Age_18_19_Female","Age_20_Female","Age_21_Female",
			"Age_22_24_Female","Age_25_29_Female","Age_30_34_Female","Age_35_39_Female","Age_40_44_Female","Age_45_49_Female" ,
			"Age_50_54_Female","Age_55_59_Female","Age_60_61_Female","Age_62_64_Female","Age_65_66_Female","Age_67_69_Female",
			"Age_70_74_Female","Age_75_79_Female","Age_80_84_Female","Age_Over_84_Female",
			"Age_Under5","Age_5_9","Age_10_14","Age_15_17","Age_18_19","Age_20", "Age_21",
			"Age_22_24","Age_25_29","Age_30_34","Age_35_39","Age_40_44","Age_45_49",
			"Age_50_54","Age_55_59","Age_60_61","Age_62_64","Age_65_66","Age_67_69",
			"Age_70_74","Age_75_79","Age_80_84","Age_Over_84",
			"Age_Under14","Age_Under19","Age_20_24",  "Age_25_34",  "Age_35_44",  "Age_45_54",  "Age_55_64",  "Age_Over_64","Age_Under14_Male","Age_Under19_Male","Age_20_24_Male",
			"Age_25_34_Male",  "Age_35_44_Male",  "Age_45_54_Male",  "Age_55_64_Male",  "Age_Over_64_Male","Age_Under14_Female" ,"Age_Under19_Female", "Age_20_24_Female","Age_25_34_Female","Age_35_44_Female","Age_45_54_Female" ,
			"Age_55_64_Female","Age_Over_64_Female", "Age_Under14_Male_Prop","Age_Under19_Male_Prop","Age_20_24_Male_Prop",
			"Age_25_34_Male_Prop",  "Age_35_44_Male_Prop",  "Age_45_54_Male_Prop",  "Age_55_64_Male_Prop",  "Age_Over_64_Male_Prop","Age_Under14_Female_Prop", "Age_Under19_Female_Prop", "Age_20_24_Female_Prop",
			"Age_25_34_Female_Prop","Age_35_44_Female_Prop","Age_45_54_Female_Prop","Age_55_64_Female_Prop","Age_Over_64_Female_Prop", "Age_Under5_Prop","Age_Under14_Prop", "Age_Under19_Prop", "Age_20_24_Prop",
			"Age_25_34_Prop", "Age_35_44_Prop", "Age_45_54_Prop", "Age_55_64_Prop", "Age_Over_64_Prop",

			#Vehicle availability
			"Vehicle_0","Vehicle_1","Vehicle_2","Vehicle_3","Vehicle_4_Plus","Vehicle_0_Prop","Vehicle_1_Prop","Vehicle_2_Prop","Vehicle_3_Prop","Vehicle_4_Plus_Prop",
			#Commute mode
			"Jtw_Motor_Vehicle","Jtw_Transit","Jtw_Bike","Jtw_Walk","Workers",
			"Jtw_Motor_Vehicle_Prop","Jtw_Transit_Prop","Jtw_Bike_Prop","Jtw_Walk_Prop",
			#Unemployment
			"Labor_Force", "Unemployment", "Unemployment_Rate"

		)
		#Add logic for geography
		if(geo == "County"){Select_Vars. <- c("County",Select_Vars.)}
		if(geo == "Urban Area"){Select_Vars. <- c("Urban_Area_Id","Urban_Area","NAME",Select_Vars.)}
		if(geo == "Zip Code"){Select_Vars. <- c("Zip_Code",Select_Vars.)}
		if(geo == "Tract"){Select_Vars. <- c("Tract","County",Select_Vars.)}
		if(geo == "Block Group"){Select_Vars. <- c("Block_Group","County",Select_Vars.)}

		#Return data
		Census..[,Select_Vars.]
	}

	#Write function to rename and prepare population and age census variable names
	############################
	all_age_race_rename <- function(dat){
		#Rename variables to meaningful names
		dat <- mutate(dat,
			#White
			#######
			#Male---
			Age_Under5_Male_W = B01001H_003E, Age_5_9_Male_W = B01001H_004E, Age_10_14_Male_W = B01001H_005E, Age_15_17_Male_W = B01001H_006E, Age_18_19_Male_W = B01001H_007E, Age_20_24_Male_W = B01001H_008E,
			Age_25_29_Male_W = B01001H_009E, Age_30_34_Male_W = B01001H_010E, Age_35_44_Male_W = B01001H_011E, Age_45_54_Male_W = B01001H_012E, Age_55_64_Male_W = B01001H_013E,
			Age_65_74_Male_W = B01001H_014E, Age_75_84_Male_W = B01001H_015E, Age_Over_84_Male_W = B01001H_016E,
			#Female---
			Age_Under5_Female_W = B01001H_018E, Age_5_9_Female_W = B01001H_019E, Age_10_14_Female_W = B01001H_020E, Age_15_17_Female_W = B01001H_021E, Age_18_19_Female_W = B01001H_022E, Age_20_24_Female_W = B01001H_023E,
			Age_25_29_Female_W = B01001H_024E, Age_30_34_Female_W = B01001H_025E, Age_35_44_Female_W = B01001H_026E, Age_45_54_Female_W = B01001H_027E, Age_55_64_Female_W = B01001H_028E,
			Age_65_74_Female_W = B01001H_029E, Age_75_84_Female_W = B01001H_030E, Age_Over_84_Female_W = B01001H_031E,
			#Black
			#######
			#Male---
			Age_Under5_Male_B = B01001B_003E, Age_5_9_Male_B = B01001B_004E, Age_10_14_Male_B = B01001B_005E, Age_15_17_Male_B = B01001B_006E, Age_18_19_Male_B = B01001B_007E, Age_20_24_Male_B = B01001B_008E,
			Age_25_29_Male_B = B01001B_009E, Age_30_34_Male_B = B01001B_010E, Age_35_44_Male_B = B01001B_011E, Age_45_54_Male_B = B01001B_012E, Age_55_64_Male_B = B01001B_013E,
			Age_65_74_Male_B = B01001B_014E, Age_75_84_Male_B = B01001B_015E, Age_Over_84_Male_B = B01001B_016E,
			#Female---
			Age_Under5_Female_B = B01001B_018E, Age_5_9_Female_B = B01001B_019E, Age_10_14_Female_B = B01001B_020E, Age_15_17_Female_B = B01001B_021E, Age_18_19_Female_B = B01001B_022E, Age_20_24_Female_B = B01001B_023E,
			Age_25_29_Female_B = B01001B_024E, Age_30_34_Female_B = B01001B_025E, Age_35_44_Female_B = B01001B_026E, Age_45_54_Female_B = B01001B_027E, Age_55_64_Female_B = B01001B_028E,
			Age_65_74_Female_B = B01001B_029E, Age_75_84_Female_B = B01001B_030E, Age_Over_84_Female_B = B01001B_031E,
			#AIAN
			#######
			#Male---
			Age_Under5_Male_AIAN = B01001C_003E, Age_5_9_Male_AIAN = B01001C_004E, Age_10_14_Male_AIAN = B01001C_005E, Age_15_17_Male_AIAN = B01001C_006E, Age_18_19_Male_AIAN = B01001C_007E, Age_20_24_Male_AIAN = B01001C_008E,
			Age_25_29_Male_AIAN = B01001C_009E, Age_30_34_Male_AIAN = B01001C_010E, Age_35_44_Male_AIAN = B01001C_011E, Age_45_54_Male_AIAN = B01001C_012E, Age_55_64_Male_AIAN = B01001C_013E,
			Age_65_74_Male_AIAN = B01001C_014E, Age_75_84_Male_AIAN = B01001C_015E, Age_Over_84_Male_AIAN = B01001C_016E,
			#Female---
			Age_Under5_Female_AIAN = B01001C_018E, Age_5_9_Female_AIAN = B01001C_019E, Age_10_14_Female_AIAN = B01001C_020E, Age_15_17_Female_AIAN = B01001C_021E, Age_18_19_Female_AIAN = B01001C_022E, Age_20_24_Female_AIAN = B01001C_023E,
			Age_25_29_Female_AIAN = B01001C_024E, Age_30_34_Female_AIAN = B01001C_025E, Age_35_44_Female_AIAN = B01001C_026E, Age_45_54_Female_AIAN = B01001C_027E, Age_55_64_Female_AIAN = B01001C_028E,
			Age_65_74_Female_AIAN = B01001C_029E, Age_75_84_Female_AIAN = B01001C_030E, Age_Over_84_Female_AIAN = B01001C_031E,
			#Asian
			#######
			#Male---
			Age_Under5_Male_A = B01001D_003E, Age_5_9_Male_A = B01001D_004E, Age_10_14_Male_A = B01001D_005E, Age_15_17_Male_A = B01001D_006E, Age_18_19_Male_A = B01001D_007E, Age_20_24_Male_A = B01001D_008E,
			Age_25_29_Male_A = B01001D_009E, Age_30_34_Male_A = B01001D_010E, Age_35_44_Male_A = B01001D_011E, Age_45_54_Male_A = B01001D_012E, Age_55_64_Male_A = B01001D_013E,
			Age_65_74_Male_A = B01001D_014E, Age_75_84_Male_A = B01001D_015E, Age_Over_84_Male_A = B01001D_016E,
			#Female---
			Age_Under5_Female_A = B01001D_018E, Age_5_9_Female_A = B01001D_019E, Age_10_14_Female_A = B01001D_020E, Age_15_17_Female_A = B01001D_021E, Age_18_19_Female_A = B01001D_022E, Age_20_24_Female_A = B01001D_023E,
			Age_25_29_Female_A = B01001D_024E, Age_30_34_Female_A = B01001D_025E, Age_35_44_Female_A = B01001D_026E, Age_45_54_Female_A = B01001D_027E, Age_55_64_Female_A = B01001D_028E,
			Age_65_74_Female_A = B01001D_029E, Age_75_84_Female_A = B01001D_030E, Age_Over_84_Female_A = B01001D_031E,
			#NHPI
			#######
			#Male---
			Age_Under5_Male_NHPI = B01001E_003E, Age_5_9_Male_NHPI = B01001E_004E, Age_10_14_Male_NHPI = B01001E_005E, Age_15_17_Male_NHPI = B01001E_006E, Age_18_19_Male_NHPI = B01001E_007E, Age_20_24_Male_NHPI = B01001E_008E,
			Age_25_29_Male_NHPI = B01001E_009E, Age_30_34_Male_NHPI = B01001E_010E, Age_35_44_Male_NHPI = B01001E_011E, Age_45_54_Male_NHPI = B01001E_012E, Age_55_64_Male_NHPI = B01001E_013E,
			Age_65_74_Male_NHPI = B01001E_014E, Age_75_84_Male_NHPI = B01001E_015E, Age_Over_84_Male_NHPI = B01001E_016E,
			#Female---
			Age_Under5_Female_NHPI = B01001E_018E, Age_5_9_Female_NHPI = B01001E_019E, Age_10_14_Female_NHPI = B01001E_020E, Age_15_17_Female_NHPI = B01001E_021E, Age_18_19_Female_NHPI = B01001E_022E, Age_20_24_Female_NHPI = B01001E_023E,
			Age_25_29_Female_NHPI = B01001E_024E, Age_30_34_Female_NHPI = B01001E_025E, Age_35_44_Female_NHPI = B01001E_026E, Age_45_54_Female_NHPI = B01001E_027E, Age_55_64_Female_NHPI = B01001E_028E,
			Age_65_74_Female_NHPI = B01001E_029E, Age_75_84_Female_NHPI = B01001E_030E, Age_Over_84_Female_NHPI = B01001E_031E,
			#Latinx
			#######
			#Male---
			Age_Under5_Male_L = B01001I_003E, Age_5_9_Male_L = B01001I_004E, Age_10_14_Male_L = B01001I_005E, Age_15_17_Male_L = B01001I_006E, Age_18_19_Male_L = B01001I_007E, Age_20_24_Male_L = B01001I_008E,
			Age_25_29_Male_L = B01001I_009E, Age_30_34_Male_L = B01001I_010E, Age_35_44_Male_L = B01001I_011E, Age_45_54_Male_L = B01001I_012E, Age_55_64_Male_L = B01001I_013E,
			Age_65_74_Male_L = B01001I_014E, Age_75_84_Male_L = B01001I_015E, Age_Over_84_Male_L = B01001I_016E,
			#Female---
			Age_Under5_Female_L = B01001I_018E, Age_5_9_Female_L = B01001I_019E, Age_10_14_Female_L = B01001I_020E, Age_15_17_Female_L = B01001I_021E, Age_18_19_Female_L = B01001I_022E, Age_20_24_Female_L = B01001I_023E,
			Age_25_29_Female_L = B01001I_024E, Age_30_34_Female_L = B01001I_025E, Age_35_44_Female_L = B01001I_026E, Age_45_54_Female_L = B01001I_027E, Age_55_64_Female_L = B01001I_028E,
			Age_65_74_Female_L = B01001I_029E, Age_75_84_Female_L = B01001I_030E, Age_Over_84_Female_L = B01001I_031E
		)

		#Sum male and female
		#---------------------------
		dat <- mutate(dat,
			#White
			Age_Under5_W = Age_Under5_Male_W + Age_Under5_Female_W, Age_5_9_W = Age_5_9_Male_W + Age_5_9_Female_W, Age_10_14_W = Age_10_14_Male_W + Age_10_14_Female_W,
				Age_15_17_W = Age_15_17_Male_W + Age_15_17_Female_W, Age_18_19_W = Age_18_19_Male_W + Age_18_19_Female_W, Age_20_24_W = Age_20_24_Male_W + Age_20_24_Female_W,
				Age_25_29_W = Age_25_29_Male_W + Age_25_29_Female_W, Age_30_34_W = Age_30_34_Male_W + Age_30_34_Female_W, Age_35_44_W = Age_35_44_Male_W + Age_35_44_Female_W,
				Age_45_54_W = Age_45_54_Male_W + Age_45_54_Female_W, Age_55_64_W = Age_55_64_Male_W + Age_55_64_Female_W, Age_65_74_W = Age_65_74_Male_W + Age_65_74_Female_W,
				 Age_75_84_W =  Age_75_84_Male_W +  Age_75_84_Female_W, Age_Over_84_W = Age_Over_84_Male_W + Age_Over_84_Female_W,
			#Black
			Age_Under5_B = Age_Under5_Male_B + Age_Under5_Female_B, Age_5_9_B = Age_5_9_Male_B + Age_5_9_Female_B, Age_10_14_B = Age_10_14_Male_B + Age_10_14_Female_B,
				Age_15_17_B = Age_15_17_Male_B + Age_15_17_Female_B, Age_18_19_B = Age_18_19_Male_B + Age_18_19_Female_B, Age_20_24_B = Age_20_24_Male_B + Age_20_24_Female_B,
				Age_25_29_B = Age_25_29_Male_B + Age_25_29_Female_B, Age_30_34_B = Age_30_34_Male_B + Age_30_34_Female_B, Age_35_44_B = Age_35_44_Male_B + Age_35_44_Female_B,
				Age_45_54_B = Age_45_54_Male_B + Age_45_54_Female_B, Age_55_64_B = Age_55_64_Male_B + Age_55_64_Female_B, Age_65_74_B = Age_65_74_Male_B + Age_65_74_Female_B,
				 Age_75_84_B =  Age_75_84_Male_B +  Age_75_84_Female_B, Age_Over_84_B = Age_Over_84_Male_B + Age_Over_84_Female_B,
			#AIAN
			Age_Under5_AIAN = Age_Under5_Male_AIAN + Age_Under5_Female_AIAN, Age_5_9_AIAN = Age_5_9_Male_AIAN + Age_5_9_Female_AIAN, Age_10_14_AIAN = Age_10_14_Male_AIAN + Age_10_14_Female_AIAN,
				Age_15_17_AIAN = Age_15_17_Male_AIAN + Age_15_17_Female_AIAN, Age_18_19_AIAN = Age_18_19_Male_AIAN + Age_18_19_Female_AIAN, Age_20_24_AIAN = Age_20_24_Male_AIAN + Age_20_24_Female_AIAN,
				Age_25_29_AIAN = Age_25_29_Male_AIAN + Age_25_29_Female_AIAN, Age_30_34_AIAN = Age_30_34_Male_AIAN + Age_30_34_Female_AIAN, Age_35_44_AIAN = Age_35_44_Male_AIAN + Age_35_44_Female_AIAN,
				Age_45_54_AIAN = Age_45_54_Male_AIAN + Age_45_54_Female_AIAN, Age_55_64_AIAN = Age_55_64_Male_AIAN + Age_55_64_Female_AIAN, Age_65_74_AIAN = Age_65_74_Male_AIAN + Age_65_74_Female_AIAN,
				 Age_75_84_AIAN =  Age_75_84_Male_AIAN +  Age_75_84_Female_AIAN, Age_Over_84_AIAN = Age_Over_84_Male_AIAN + Age_Over_84_Female_AIAN,
			#Asian
			Age_Under5_A = Age_Under5_Male_A + Age_Under5_Female_A, Age_5_9_A = Age_5_9_Male_A + Age_5_9_Female_A, Age_10_14_A = Age_10_14_Male_A + Age_10_14_Female_A,
				Age_15_17_A = Age_15_17_Male_A + Age_15_17_Female_A, Age_18_19_A = Age_18_19_Male_A + Age_18_19_Female_A, Age_20_24_A = Age_20_24_Male_A + Age_20_24_Female_A,
				Age_25_29_A = Age_25_29_Male_A + Age_25_29_Female_A, Age_30_34_A = Age_30_34_Male_A + Age_30_34_Female_A, Age_35_44_A = Age_35_44_Male_A + Age_35_44_Female_A,
				Age_45_54_A = Age_45_54_Male_A + Age_45_54_Female_A, Age_55_64_A = Age_55_64_Male_A + Age_55_64_Female_A, Age_65_74_A = Age_65_74_Male_A + Age_65_74_Female_A,
				 Age_75_84_A =  Age_75_84_Male_A +  Age_75_84_Female_A, Age_Over_84_A = Age_Over_84_Male_A + Age_Over_84_Female_A,
			#NHPI
			Age_Under5_NHPI = Age_Under5_Male_NHPI + Age_Under5_Female_NHPI, Age_5_9_NHPI = Age_5_9_Male_NHPI + Age_5_9_Female_NHPI, Age_10_14_NHPI = Age_10_14_Male_NHPI + Age_10_14_Female_NHPI,
				Age_15_17_NHPI = Age_15_17_Male_NHPI + Age_15_17_Female_NHPI, Age_18_19_NHPI = Age_18_19_Male_NHPI + Age_18_19_Female_NHPI, Age_20_24_NHPI = Age_20_24_Male_NHPI + Age_20_24_Female_NHPI,
				Age_25_29_NHPI = Age_25_29_Male_NHPI + Age_25_29_Female_NHPI, Age_30_34_NHPI = Age_30_34_Male_NHPI + Age_30_34_Female_NHPI, Age_35_44_NHPI = Age_35_44_Male_NHPI + Age_35_44_Female_NHPI,
				Age_45_54_NHPI = Age_45_54_Male_NHPI + Age_45_54_Female_NHPI, Age_55_64_NHPI = Age_55_64_Male_NHPI + Age_55_64_Female_NHPI, Age_65_74_NHPI = Age_65_74_Male_NHPI + Age_65_74_Female_NHPI,
				 Age_75_84_NHPI =  Age_75_84_Male_NHPI +  Age_75_84_Female_NHPI, Age_Over_84_NHPI = Age_Over_84_Male_NHPI + Age_Over_84_Female_NHPI,
			#LAtinx
			Age_Under5_L = Age_Under5_Male_L + Age_Under5_Female_L, Age_5_9_L = Age_5_9_Male_L + Age_5_9_Female_L, Age_10_14_L = Age_10_14_Male_L + Age_10_14_Female_L,
				Age_15_17_L = Age_15_17_Male_L + Age_15_17_Female_L, Age_18_19_L = Age_18_19_Male_L + Age_18_19_Female_L, Age_20_24_L = Age_20_24_Male_L + Age_20_24_Female_L,
				Age_25_29_L = Age_25_29_Male_L + Age_25_29_Female_L, Age_30_34_L = Age_30_34_Male_L + Age_30_34_Female_L, Age_35_44_L = Age_35_44_Male_L + Age_35_44_Female_L,
				Age_45_54_L = Age_45_54_Male_L + Age_45_54_Female_L, Age_55_64_L = Age_55_64_Male_L + Age_55_64_Female_L, Age_65_74_L = Age_65_74_Male_L + Age_65_74_Female_L,
				 Age_75_84_L =  Age_75_84_Male_L +  Age_75_84_Female_L, Age_Over_84_L = Age_Over_84_Male_L + Age_Over_84_Female_L
		)
		#Return data frame
		dat
	}

#Grab and perpare Census Data
#----------------------------------------------------------------
	#ACS Data look up - this is a utility if you are after other Census data elements
	########################
	#acs.lookup(keyword = "B08301", endyear = 201)
	#x <- acs.lookup(table.name = "B25044", endyear = 2015)
	#x <-  acs.lookup(endyear=2018, table.name="employment",case.sensitive=F)

	#Initialize Census Key
	#api.key.install(Developer_Key)
	#Define census variables to download
	#Census table name sexplained https://www.census.gov/programs-surveys/acs/guidance/which-data-tool/table-ids-explained.html
	#Define census variables of interest
	################################
	Vars. <- c(
		#Total Population---
		#"B17001_001",
		"B01003_001",
		#Population below Poverty---
		"B17021_002",
		#Population with disability and Receive Food stamps
		#SNAP households, SNAP and household with 1 or more disabled persons: SNAP but no disables persons: No SNAP but 1 or more disabled persons
		"B22010_002","B22010_003", "B22010_004",  "B22010_006",
		#English proficiency
		#"B16004_021E +B16004_022E +B16004_023E +B16004_043E +B16004_044E +B16004_045E +B16004_065E +B16004_066E +B16004_067",
		"B16004_006","B16004_007","B16004_008","B16004_011","B16004_012","B16004_013","B16004_016","B16004_017","B16004_018","B16004_021","B16004_022","B16004_023",
		"B16004_028","B16004_029","B16004_030","B16004_033","B16004_034","B16004_035","B16004_038","B16004_039","B16004_040","B16004_043","B16004_044","B16004_045",
		"B16004_050","B16004_051","B16004_052","B16004_055","B16004_056","B16004_057","B16004_060","B16004_061","B16004_062","B16004_065","B16004_066","B16004_067",
		#Total housholds
		"B22010_001",
		#Population by Race---
		#White, Black or African American, American Indian & Alaska Native, Asian, Hawaiin or other pacific islander, "Some other race alone", "Two or more races:" ,
		#"Two or more races: Two races including Some other race","Two or more races: Two races excluding Some other race, and three or more races", Hispanic or Latino
		"B02001_002","B02001_003","B02001_004", "B02001_005", "B02001_006", "B02001_007","B02001_008", "B02001_009","B02001_010","B03002_012",
		#Median Income---
		"B19013_001",
		#Population by Age/Sex---
		#Male/Femal Under 5 years, 5 to 9 years, 10 to 14 years, 15 to 17 years, 18 and 19 years, 20 years, 21 years, 22 to 24 years, 25 to 29 years, 30 to 34 years, 35 to 39 years
		#40 to 44 years, 45 to 49 years, 50 to 54 years, 55 to 59 years, 60 and 61 years, 62 to 64 years, 65 and 66 years, 67 to 69 years, 70 to 74 years,
		#"75 to 79 years", "80 to 84 years",  "85 years and over"
		#Male
		c(paste("B01001_",str_pad(seq(3,25),3,pad="0"),sep=""),
		#Female
		paste("B01001_",str_pad(seq(27,49),3,pad="0"),sep="")),
		#Vehicles available
		#"B08014_002"," B08014_003","B08014_004","B08014_005","B08014_006","B08014_007",
		#"B08201_002","B08201_003","B08201_004","B08201_005","B08201_006", this wasnt working for block groups
		"B25044_003", "B25044_010", "B25044_004", "B25044_011", "B25044_005", "B25044_012", "B25044_006", "B25044_013", "B25044_007", "B25044_014", "B25044_008", "B25044_015",
		#Workers
		"B08301_001",
		#Journey to work----
		#Car, truck, van---
		"B08301_002",
		#Public transit
		"B08301_010",
		#Motorcycle, Bicycle, Walk
		"B08301_017","B08301_018","B08301_019",
		#Unemployment (Workers in labor force, unemployed labor force
		"B23025_002", "B23025_005"

	)

	#Tract
	######################################
	#Create an object to store retreived data
	Store_Census.. <- data.frame()
	for(acs_year in Acs_Years.){
		#Get the data for Oregon
		Load_Census.. <- get_acs(geography = "tract", variables = Vars., state = "OR", output = "wide", year = acs_year, geometry = F, key =	Developer_Key)
		#Run custom rename function
		Census.. <- mutate(rename_ACS_vars(Load_Census.., geo = "Tract"), Year = acs_year)
		#Append year and store in one data set
		Store_Census.. <- rbind(Store_Census..,Census..)
	}
	#Save to directory
	#################
	#Name your file here
	Save_File_Name <- ""
	save(Store_Census.., file = Save_File_Name)


#研究f_eject射出次数和频率
#分为eject单次射出，即单脉冲内射出的次数
#还有eject，总体射出频率

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

#读取数据
k2 <- read.xlsx("f_eject.xls", sheetName = "eject_k2", header = TRUE)
#k3 <- read.xlsx("f_eject.xls", sheetName = "eject_k3", header = TRUE)
#k4 <- read.xlsx("f_eject.xls", sheetName = "eject_k4", header = TRUE)
#k5 <- read.xlsx("f_eject.xls", sheetName = "eject_k5", header = TRUE)

#保存数据
#pdf("f_e0.2.pdf")

#画图
#设定空间位置
par(fig=c(0,1,0,1), new = F)

##################################画图--占空比k为0.2#######################
plot(k2$fv, k2$X1.5, xaxs = "i", col = 0, xlab = "Voltage frequency (Hz)", ylab = "Frequency in 1s (Hz)", main = "Eject frequency in duty = 0.2", cex.lab = 1.2, cex.main = 1.5, xlim = c(0, 1050), ylim = c(70, 1550))

#model1 = loess(k2$X1.5 ~ k2$fv, span = 0.8 , degree = 2)
lines(k2$fv, k2$X1.5,  col="#458B74", pch=21, lwd=2.5, type="b", lty=2)

#model2 = loess(k2$X27 ~ k2$fv, span = 0.8, degree = 2)
lines(k2$fv, k2$X27, col="#FF00FF", pch=22, lwd=2.5, type="b", lty=2)

#model3 = loess(k2$X54 ~ k2$fv, span = 0.8, degree = 2)
lines(k2$fv, k2$X54, col="#EE0000", pch=23, lwd=2.5, type="b", lty=2)

#model4 = loess(k2$X180 ~ k2$fv, span = 0.8, degree =2)
lines(k2$fv, k2$X180, col="#27408B", pch=24, lwd=2.5, type="b", lty=2)

#区域划线
abline(v=700, lty = 3, col ="red", lwd = 3)
text(750, 680, "700Hz", col = "blue", cex = 1.5, font = 2)

legend("topleft", c("1.5nl/min", "27nl/min", "54nl/min", "180nl/min"), col = c("#458B74", "#FF00FF", "#EE0000", "#27408B"), pch = c(21, 22, 23, 24), lwd = 2, lty = 2, cex = 1.2, inset = .03, bty = "n")

#dev.off()