Skip to content

Commit fe782e2

Browse files
wagnerdswagnerds
committed
2 parents ee9b3ea + e6934d2 commit fe782e2

17 files changed

Lines changed: 9061 additions & 8708 deletions

‎fvsOL/DESCRIPTION‎

Lines changed: 6 additions & 5 deletions
Original file line numberDiff line numberDiff line change
@@ -1,16 +1,17 @@
11
Package: fvsOL
22
Title: Forest Vegetation Simulator
3-
Version: 2023.07.28
3+
Version: 2024.04.01
44
Authors@R: c(person("Nicholas", "Crookston", email = "ncrookston.fs@gmail.com",
55
role = c("aut")),
66
person("FVS", "Staff", email = "sm.fs.fvs-support@usda.gov",
77
role = c("aut", "cre")))
88
Description: An R-Shiny interface to the Forest Vegetation Simulator which can be
99
run as an "Online" or "Onlocal" configuration.
10-
Depends: R (>= 4.0.0), rFVS (>= 2021.03.15), shiny (>= 1.6.0), Cairo (>= 1.5.11),
11-
rhandsontable (>= 0.3.7), ggplot2 (>= 3.3.3), parallel (>= 4.0.0),
12-
RSQLite (>= 2.2.4), plyr (>= 1.8.6), dplyr (>= 1.0.4), colourpicker (>= 1.1.0),
13-
rgl (>= 0.105.0), leaflet (>= 2.0.4.1), zip (>= 2.1.1), openxlsx (>= 4.2.3)
10+
Depends:
11+
R (>= 4.0.0), rFVS (>= 2021.03.15), shiny (>= 1.6.0), Cairo (>= 1.5.11), rhandsontable (>= 0.3.7),
12+
ggplot2 (>= 3.3.3), parallel (>= 4.0.0), RSQLite (>= 2.2.4), plyr (>= 1.8.6), dplyr (>= 1.0.4),
13+
colourpicker (>= 1.1.0), rgl (>= 0.105.0), leaflet (>= 2.0.4.1), zip (>= 2.1.1), openxlsx (>= 4.2.3),
14+
shinyFiles (>= 0.9.3)
1415
Suggests: rgdal (>= 1.5-23), nlme (>= 3.1-140)
1516
License: MIT
1617
Roxygen: list(markdown = TRUE)

‎fvsOL/R/change_project_dir.R‎

Lines changed: 96 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,96 @@
1+
####################################################################################
2+
# change_project_dir - r.20230711
3+
#
4+
# Accepts path to directory
5+
#
6+
# Opens new interface instance with last modified project in chosen directory
7+
#
8+
# makes heavy usage of code from server.R for input input$PrjOpen
9+
#
10+
# Function does not verify user access to chosen directory,
11+
# must be handled prior to function call
12+
####################################################################################
13+
14+
15+
change_project_dir <- function(new_proj_dir) {
16+
cat(paste0("User Specified Dir: ", new_proj_dir))
17+
18+
if (dir.exists(new_proj_dir)) {
19+
if (isLocal()) {
20+
if (exists("RscriptLocation")) {
21+
rscript= RscriptLocation
22+
} else {
23+
exe_file = normalizePath(commandArgs(trailingOnly = FALSE)[1])
24+
25+
if (.Platform$OS.type == "windows") {
26+
bin = regexpr("\\\\bin\\\\", exe_file)
27+
} else {
28+
bin = regexpr("/bin/", exe_file)
29+
}
30+
31+
bin = substr(exe_file, 1, bin + attr(bin, "match.length") - 2)
32+
33+
if (.Platform$OS.type == "windows") {
34+
file.path(bin,"Rscript.exe")
35+
} else {
36+
file.path(bin,"Rscript")
37+
}
38+
}
39+
40+
rscript = gsub("\\\\", "/", rscript)
41+
defs = paste0("RscriptLocation='", rscript, "';")
42+
43+
if (exists("mdbToolsDir")) {
44+
defs = paste0(defs, "mdbToolsDir='", mdbToolsDir, "';")
45+
}
46+
47+
if (exists("sqlite3exe")) {
48+
defs = paste0(defs, "sqlite3exe='", sqlite3exe, "';")
49+
}
50+
51+
cat(".libPaths=", unlist(.libPaths()), "\n")
52+
53+
if (exists("RscriptLocation")) {
54+
Rlib2Use <-
55+
paste0(dirname(dirname(dirname(RscriptLocation))), "/library")
56+
defs = paste0(defs, ".libPaths('", Rlib2Use, "');")
57+
}
58+
59+
# Get list of projects in supplied Directory
60+
prjs = list()
61+
dirs = dir(new_proj_dir)
62+
for (dir in dirs) {
63+
if (file.exists(paste0(new_proj_dir, "/", dir, "/projectId.txt"))){
64+
prjs = append(prjs, paste0(new_proj_dir, "/", dir))
65+
prjs <- as.character((prjs))
66+
}
67+
}
68+
69+
if (!length(prjs)) {
70+
if (file.exists(paste0(new_proj_dir, "/Project_1/projectId.txt"))) {
71+
#Display notice of locked project
72+
} else {
73+
#Create new project_1 directory and launch
74+
dir.create(paste0(new_proj_dir, "/Project_1"))
75+
write(file = paste0(new_proj_dir, "/Project_1/projectId.txt"),
76+
"title= Project_1")
77+
prjs = append(prjs, paste0(new_proj_dir, "/Project_1"))
78+
}
79+
}
80+
81+
ord = sort(unlist(lapply(prjs, function(x) as.integer(file.mtime(x)))),
82+
decreasing = TRUE, index.return = TRUE)$ix
83+
84+
cmd = paste0("$",rscript,"$ --vanilla -e $", defs, "require(fvsOL)",
85+
";fvsOL(prjDir='", prjs[ord[1]], "',fvsBin='", fvsBin, "');
86+
quit()$")
87+
cmd = gsub('$', '\"', cmd, fixed=TRUE)
88+
89+
if (.Platform$OS.type == "unix") {
90+
cmd = paste0("nohup ", cmd, " >> /dev/null")
91+
}
92+
rtn=try(system(cmd, wait=FALSE))
93+
cat("cmd for launch project=", cmd, "\nrtn=", rtn, "\n")
94+
}
95+
}
96+
}

‎fvsOL/R/checkMinColumnDefs.R‎

Lines changed: 142 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,142 @@
1+
checkMinColumnDefs <- function(dbo, progress = NULL, pn = 0) {
2+
cat("In checkMinColumnDefs\n")
3+
# Set up list of column names that are automatic database rejection
4+
reject_if_missing <- c("Variant", "Stand_ID", "Inv_Year")
5+
6+
# Set up data frame to dub in required columns if missing
7+
StdInitColumnReq <- data.frame(
8+
ColumnName = c("Groups", "FVSKeywords", "Sam_Wt"),
9+
DataType = c("text", "text", "real"),
10+
Default = c("'All_Stands'", NA, NA)
11+
)
12+
13+
FVS_StandInit = FALSE
14+
valid_table_found = FALSE
15+
FIA_dataset = FALSE
16+
FIA_Tables = c("FVS_StandInit_Plot", "FVS_PlotInit_Plot", "FVS_StandInit_Cond")
17+
for (table in FIA_Tables) {
18+
tryCatch(
19+
# Try to read table from db connection
20+
{
21+
stdInit <- dbReadTable(dbo, table)
22+
FIA_dataset = TRUE
23+
},
24+
25+
# if an error . . .
26+
error = function(e) {
27+
cat(paste0("Table: ", table, " not found in database\n"))
28+
}
29+
)
30+
}
31+
if (FIA_dataset) return(NULL)
32+
33+
for (initnm in c("FVS_StandInit", "FVS_PlotInit")) {
34+
initnm_exists = FALSE
35+
tryCatch(
36+
# Try to read table from db connection
37+
{
38+
stdInit <- dbReadTable(dbo, initnm)
39+
initnm_exists = TRUE
40+
valid_table_found = TRUE
41+
},
42+
43+
# if an error . . .
44+
error = function(e) {
45+
cat(paste0("Table: ", initnm, " not found in database\n"))
46+
}
47+
)
48+
if (initnm_exists) {
49+
if (initnm == "FVS_StandInit") FVS_StandInit = TRUE
50+
51+
# get list of column names in table
52+
fields <- tolower(names(stdInit))
53+
reject = reject_if_missing
54+
55+
if (initnm == 'FVS_PlotInit' || initnm == 'FVS_PlotInit_Plot') {
56+
plotInit = c("StandPlot_ID")
57+
reject = c(reject_if_missing, plotInit)
58+
}
59+
60+
61+
# Check for missing required columns that would reject database
62+
for (e in reject) {
63+
if (!is.null(progress)) {
64+
pn = pn+1
65+
progress$set(message = paste0("Checking ", initnm), value = pn,
66+
detail = e)
67+
}
68+
69+
if (!(tolower(e) %in% fields)) {
70+
return(paste0("<h4>Input database invalid.<br>",
71+
initnm, " table Missing column: '", e, "'</h4>"))
72+
}
73+
74+
# Add logic to check for blank entries
75+
# Note: Sqlite extensions 'math', 'regexp', 'series', 'csv' not enabled by default
76+
RSQLite::initExtension(dbo, extension = c('regexp'))
77+
q <- paste0("SELECT COUNT(*) FROM ", initnm, " WHERE ", e,
78+
" NOT REGEXP '[A-Za-z0-9_]' OR ", e, " IS NULL")
79+
80+
if (tolower(e) == 'inv_year'){
81+
q <- paste0("SELECT COUNT (*) FROM ", initnm, " WHERE CAST(INV_YEAR AS INT) <= 0 OR INV_YEAR IS NULL")
82+
}
83+
tryCatch(
84+
{
85+
result <- dbGetQuery(dbo, q)
86+
if (result > 0) {
87+
return(paste0("<h4>Input database invalid.<br>",
88+
initnm, " Column ", e, " contains a blank or missing value</h4>"))
89+
}
90+
},
91+
error = function(e) {
92+
return(paste0("Attempt to read column: ", e, "Failed."))
93+
}
94+
)
95+
}
96+
97+
for (reqColumn in StdInitColumnReq$ColumnName) {
98+
type = StdInitColumnReq$DataType[
99+
StdInitColumnReq$ColumnName == reqColumn]
100+
101+
default = StdInitColumnReq$Default[
102+
StdInitColumnReq$ColumnName == reqColumn]
103+
104+
if (reqColumn == "Groups" &&
105+
(initnm == "FVS_PlotInit" || initnm == "FVS_PlotInit_Plot")) {
106+
default = "'All_Plots'"
107+
}
108+
109+
if (!is.null(progress)) {
110+
pn = pn + 1
111+
progress$set(message = paste0("Checking ", initnm),
112+
value = pn, detail = reqColumn)
113+
}
114+
115+
if (!(tolower(reqColumn) %in% fields)) {
116+
117+
tryCatch(
118+
{
119+
if(!is.na(default)){
120+
dbExecute(dbo, paste0("alter table ", initnm, " add column ",
121+
reqColumn, " ", type, " default ", default, ";"))
122+
}
123+
else{
124+
dbExecute(dbo, paste0("alter table ", initnm, " add column ",
125+
reqColumn, " ", type, ";"))
126+
}
127+
128+
},
129+
error = function(e) {
130+
return(paste0("Attempt to add column: ", reqColumn, "Failed."))
131+
}
132+
)
133+
}
134+
}
135+
}
136+
}
137+
if (!valid_table_found) {
138+
return(paste0("<h4>Input database invalid.<br>",
139+
"No valid StandInit or PlotInit tables found</h4>"))
140+
}
141+
return(NULL)
142+
}

‎fvsOL/R/editDataUtilities.R‎

Lines changed: 0 additions & 118 deletions
Original file line numberDiff line numberDiff line change
@@ -27,124 +27,6 @@ cat(" qry=",qry,"\n")
2727
dbGlb$tbl$Delete = FALSE
2828
}
2929

30-
checkMinColumnDefs <- function(dbo,progress=NULL,pn=0)
31-
{
32-
cat ("in checkMinColumnDefs\n")
33-
for (initnm in c("FVS_StandInit","FVS_PlotInit","FVS_StandInit_Cond"))
34-
{
35-
stdInit = getTableName(dbo,initnm)
36-
if (!is.null(stdInit)) break
37-
}
38-
cat ("stdInit=",stdInit,"\n")
39-
if (is.null(stdInit)) return("No standinit table was found.")
40-
fields = try(dbListFields(dbo,stdInit))
41-
# if this is an error, then FVS_StandInit does not exist and this is an error
42-
# where the standard fixup in this case is to try recovery of the database.
43-
if (class(fields) == "try-error") return("Geting column names from StandInit table failed.")
44-
sID = FALSE
45-
sCN = FALSE
46-
grp = FALSE
47-
# make sure groups are defined, if missing set one to "All_Stands"
48-
if (!is.null(progress)) progress$set(message = paste0("Checking ",stdInit),
49-
value = pn+1, detail = "Groups")
50-
if (length(grep("Groups",fields,ignore.case=TRUE)) == 0)
51-
{
52-
qt = try(dbExecute(dbo,paste0("alter table '",stdInit,
53-
"' add column Groups text default 'All All_Stands'")))
54-
if (class(qt)=="try-error") return ("Adding group 'All All_Stands' to StandInit failed.")
55-
grp = TRUE
56-
}
57-
# make sure Stand_ID is defined
58-
if (!is.null(progress)) progress$set(message = paste0("Checking ",stdInit),
59-
value = pn+2, detail = "Stand_ID")
60-
if (length(grep("Stand_ID",fields,ignore.case=TRUE)) == 0)
61-
{
62-
qt = try(dbExecute(dbo,paste0("alter table '",stdInit,
63-
"' add column Stand_ID text")))
64-
if (class(qt)=="try-error") return ("Adding 'Stand_ID' to StandInit failed.")
65-
sID = TRUE
66-
}
67-
# make sure Stand_CN is defined
68-
if (!is.null(progress)) progress$set(message = paste0("Checking ",stdInit),
69-
value = pn+3, detail = "Stand_CN")
70-
if (length(grep("Stand_CN",fields,ignore.case=TRUE)) == 0)
71-
{
72-
qt = try(dbExecute(dbo,paste0("alter table '",stdInit,
73-
"' add column Stand_CN text")))
74-
if (class(qt)=="try-error") return ("Adding 'Stand_CN' to StandInit failed.")
75-
sCN = TRUE
76-
}
77-
# make sure Inv_Year is defined
78-
if (!is.null(progress)) progress$set(message = paste0("Checking ",stdInit),
79-
value = pn+4, detail = "Inv_Year ")
80-
if (length(grep("Inv_Year",fields,ignore.case=TRUE)) == 0)
81-
{
82-
year=substring(as.character(Sys.time()),1,4)
83-
qt=try((dbExecute(dbo,paste0(paste0("alter table '",stdInit,
84-
"' add column Inv_Year integer default ",year)))))
85-
if (class(qt)=="try-error") return ("Adding 'Inv_Year' to StandInit failed.")
86-
}
87-
# make sure FVSKeywords is defined
88-
if (!is.null(progress)) progress$set(message = paste0("Checking ",stdInit),
89-
value = pn+5, detail = "FVSKeywords ")
90-
if (length(grep("FVSKeywords",fields,ignore.case=TRUE)) == 0)
91-
{
92-
year=substring(as.character(Sys.time()),1,4)
93-
qt=try(dbExecute(dbo,paste0("alter table '",stdInit,
94-
"' add column FVSKeywords text")))
95-
if (class(qt)=="try-error") return ("Adding 'FVSKeywords' to StandInit failed.")
96-
}
97-
# make sure Sam_Wt is defined
98-
if (!is.null(progress)) progress$set(message = paste0("Checking ",stdInit),
99-
value = pn+6, detail = "Sam_Wt")
100-
if (length(grep("Sam_Wt",fields,ignore.case=TRUE)) == 0)
101-
{
102-
qt=try(dbExecute(dbo,paste0("alter table ",stdInit,
103-
" add column Sam_Wt real")))
104-
if (class(qt)=="try-error") return ("Adding 'Sam_Wt' to StandInit failed.")
105-
}
106-
cat ("in checkMinColumnDefs sID=",sID," sCN=",sCN,"\n")
107-
if (sID || sCN)
108-
{
109-
fvsInit = try(dbReadTable(dbo,stdInit))
110-
if (class(fvsInit)=="try-error") return ("Can not read StandInit.")
111-
if (!is.null(progress)) progress$set(message = paste0("Checking ",stdInit),
112-
value = pn+7, detail = "Stand_ID and Stand_CN consistent")
113-
if (nrow(fvsInit))
114-
{
115-
isCN = grep("Stand_CN",names(fvsInit),ignore.case=TRUE)
116-
if (sID) fvsInit$Stand_ID =
117-
if (sCN) paste0("Stand",1:nrow(fvsInit)) else fvsInit[,isCN]
118-
isID = grep("Stand_ID",names(fvsInit),ignore.case=TRUE)
119-
if (sCN)
120-
{
121-
isCN = grep("Stand_CN",names(fvsInit),ignore.case=TRUE)
122-
fvsInit[,isCN] = fvsInit[,isID]
123-
isID = grep("Stand_ID",names(fvsInit),ignore.case=TRUE)
124-
fvsInit[,isCN] = fvsInit[,isID]
125-
}
126-
dbWriteTable(dbo,stdInit,fvsInit,overwrite=TRUE)
127-
}
128-
}
129-
# check groups
130-
if (!grp)
131-
{
132-
if (!is.null(progress)) progress$set(message = paste0("Checking ",stdInit),
133-
value = pn+8, detail = "Groups content")
134-
grps = try(dbGetQuery(dbo,paste0("select Groups from '",stdInit,"'")))
135-
if (class(grps)=="try-error") return ("Can not read Groups from StandInit.")
136-
names(grps) = toupper(names(grps))
137-
if (is.null(grps$GROUPS) || any(is.na(grps$GROUPS)) || any(grps$GROUPS == ""))
138-
{
139-
qt =try(dbExecute(dbo,paste0("update '",stdInit,
140-
" set Groups = 'All_Stands' where Groups = ''")))
141-
if (class(qt)=="try-error") return ("Failure updating 'Groups' in StandInit.")
142-
}
143-
}
144-
return(NULL)
145-
}
146-
147-
14830
fixFVSKeywords <- function(dbo)
14931
{
15032
tbs <- dbGetQuery(dbo,"select name from sqlite_master where type='table';")[,1]

0 commit comments

Comments
 (0)