RSFIA: FIA Tree Mortality Analysis

#### NOTES FOR USE ####
## This function is designed to make a schedule file with as few *required* arguments as possible.  It starts with a dummy schedule file
## as its arguments, most of which can be ignored and sensible defaults will be used.  Required arguments for an independent schedule file are:
## startingyear -- calendar year in which the simulation starts
## lastyears -- calendar years in which each simulation BLOCK ends (same as simulation lastyear for single-block schedules)
## sitefilename -- name (and location if not in pwd) of site.100 file
## weatherfilename -- name (and location if not in pwd) of weather.wth file
## events -- string vector of event blocks, in which each event occupies one line, and each block is enclosed in its own quotation marks
##						so that R stores each event block as a single vector element
##						The quote-enclosures tell R where to separate vector elements, and the vector elements tell this function how many event
##						blocks are in the schedule file.

dc_sched <- function(
	#general header lines
	h1 = "1848          Starting year\n", #header line 1
		startingyear, #starting year for the simulation
	h2 = "1900          Last year\n",
		lastyear, #ending year for the simulation
	h3 = "site.100      Site file name\n",
	h4 = "0             Labeling type\n",
	h5 = "-1            Labeling year\n",
	h6 = "-1            Microcosm\n",
	h7 = "-1            CO2 Systems\n",
	h8 = "", #placeholder, this has years when CO2 systems are active
	h9 = "-1            pH Effect\n",
	h10= "-1            Soil Warming\n",
	h11= "0             N input scalar option\n",
	h12= "", #placeholder for N input scalar years
	h13= "0             OMAD scalar option\n",
	h14= "0             Climate scalar option\n",
	h15= "1             Initial system\n",
	h16= "TMC4          Initial crop\n",
	h17= "              Initial tree\n",
	h18= "\n",
	h19= "Year Month Option\n",
	#block-header lines
		blklastyears,
		outputstartingyear=NULL,
		events,
	bh1= "1             Block #\n",
	bh2 = "1900          Last year\n",
	bh3 = "3             Repeats # years\n",
	bh4 = "1848          Output starting year\n",
	bh5 = "12            Output month\n",
	bh6 = "1.0         Output interval\n",
	bh7 = "F             Weather choice\n",
	bh8 = "weather.wth\n"
)  #END OF ARGUMENTS LIST

{  #### ACTUAL FUNCTION STARTS HERE
	library(stringr)
	
	if(length(events) != length(blklastyears)) { stop("ERROR: Number of quoted event blocks must match number of block ending-years") }
	blklastyears <- as.character(blklastyears)
	## check if arguments are supplied and if so replace the default line values
	h1 = str_replace(h1, "\\d+", as.character(startingyear)) #starting year of simulation
	h2 = str_replace(h2, "\\d+", as.character(lastyear)) #last year of simulation
	header <- paste0(h1,h2,h3,h4,h5,h6,h7,h8,h9,h10,h11,h12,h13,h14,h15,h16,h17,h18,h19)
	## write out the block header and events in a loop
	allblocks <- vector()
	events <- events[(!is.na(events))]
	events <- events[events!=""]
	events <- paste0(events,"\n\n") #append a few extra newlines to each event block (quoted element) to avoid problems later
# cat("events are",events,"\n")
# cat("length of events are",length(events),"\n")
# cat("the second element of events is",events[2],"\n")
	if(is.null(outputstartingyear) | is.na(outputstartingyear)) { outputstartingyear = startingyear } #if not specified, set this equal to the simulation start year
	for(i in 1:length(events))
	{
		bh1 <- str_replace(bh1, "^\\d+", as.character(i)) #change the block # in the header
		bh2 <- str_replace(bh2, "^\\d+", blklastyears[i]) #user-supplied ending years for each block 
		
			myevents <- unlist(strsplit(events[i],"\\/")) #split the block into individual events
			blocknyear <- str_extract(myevents[length(myevents)], "^\\d+") #get the year-integer for the last event in the block
		bh3 <- str_replace(bh3, "^\\d+", blocknyear) #put in correct value for "Repeats # Years"
		bh4 <- str_replace(bh4, "^\\d+", as.character(outputstartingyear)) #specify when output starts getting written
		if(i > 1) {	bh7 <- str_replace(bh7, "^F", "C") }  #continue reading weather for blocks after the first one
		
		if(!grepl(pattern="PLTM",x=events[i])) #if you forgot PLTM events this will place one after every CROP event in the block
		{
			myevtvec <- unlist(str_split(string=events[i],pattern="\\/"))
			evtvechrvs <- which(grepl("CROP",myevtvec)) #get indices of CROP events in the evt vector
			mycrop <- grep("CROP",myevtvec,value=T) #get the actual CROP events
			mypltm <- str_replace_all(mycrop,"CROP","PLTM") #swap the text CROP for PLTM
			mypltm <- str_extract_all(mypltm,"^\\d.+PLTM",simplify=T) #leave off the actual crop name
			mycroppltm <- paste0(mycrop,"/",mypltm) #paste the PLTM onto the CROP event
			myevtvec[evtvechrvs] <- mycroppltm #replace the CROP event with the CROP/PLTM event
			events[i] <- paste(myevtvec,collapse="/") #paste them back together
		}

		if(!grepl(pattern="LAST",x=events[i])) #if you forgot LAST events this will place one after every HARV event in the block
		{
			myevtvec <- unlist(str_split(string=events[i],pattern="\\/"))
			evtvechrvs <- which(grepl("HARV",myevtvec))
			myharv <- grep("HARV",myevtvec,value=T)
			mylast <- str_replace_all(myharv,"HARV","LAST")
			mylast <- str_extract_all(mylast,"^\\d.+LAST",simplify=T)
			myharvlast <- paste0(myharv,"/",mylast,"\n")
			myevtvec[evtvechrvs] <- myharvlast
			events[i] <- paste(myevtvec,collapse="/")
		}
			
		events[i] <- str_replace_all(string=events[i],pattern = "\\/",replacement = "\n") #swap the "/" delimiter for a line-break within event block
		if(i==1) { thisblock <- paste0(bh1,bh2,bh3,bh4,bh5,bh6,bh7,bh8,events[i]) } else { thisblock <- paste0(bh1,bh2,bh3,bh4,bh5,bh6,bh7,events[i]) }#paste lines into a block-header+events
		allblocks <- paste0(allblocks,thisblock,"\n-999 -999 X\n") #paste current block into position after previous blocks
	}
	return(paste0(header,allblocks)) #paste together header, event blocks, and file-end sequence
}