diff --git a/.travis.yml b/.travis.yml index 470196df18ff47dbd33a90aa972f84a9e773d161..e89ee26523d3d5d81dd717e2c6cb3a4c992a8507 100644 --- a/.travis.yml +++ b/.travis.yml @@ -7,9 +7,8 @@ addons: apt: update: true packages: - - libgsl0-dbg - - libgsl0-dev - - libgsl0ldbl + - libgsl-dbg + - libgsl-dev r_packages: testthat diff --git a/DESCRIPTION b/DESCRIPTION index 8335e8d5962cd153d83af96bea7dfe2dda63cc0b..c9df7b1ae053d2b8c4a53671ca825acbe4154271 100644 --- a/DESCRIPTION +++ b/DESCRIPTION @@ -1,42 +1,42 @@ -Package: GenEst -Title: Generalized Mortality Estimator -Version: 1.2.4 -Date: 2019-04-12 -Authors@R: c( - person("Daniel", "Dalthorp", , "ddalthorp@usgs.gov", c("aut", "cre")), - person("Juniper", "Simonis", , "simonis@dapperstats.com", "aut"), - person("Lisa", "Madsen", , "madsenl@oregonstate.edu", "aut"), - person("Manuela", "Huso", , "mhuso@usgs.gov", "aut"), - person("Paul", "Rabie", , "prabie@west-inc.com", "aut"), - person("Jeffrey", "Mintz", , "mintzj@oregonstate.edu", "aut"), - person("Robert", "Wolpert", , "wolpert@stat.duke.edu", "aut"), - person("Jared", "Studyvin", , "jstudyvin@west-inc.com", "aut"), - person("Franzi", "Korner-Nievergelt", , "fraenzi.korner@oikostat.ch", "aut")) -Description: Command-line and 'shiny' GUI implementation of the GenEst models for estimating bird and bat mortality at wind and solar power facilities, following Dalthorp, et al. (2018) <doi:10.3133/tm7A2>. -Depends: R (>= 3.5.0) -License: CC0 -Encoding: UTF-8 -LazyData: true -Imports: - cbinom (>= 1.3), - corpus, - DT, - gsl, - gtools, - htmltools, - lubridate, - matrixStats, - mvtnorm, - Rcpp, - shiny, - shinyjs, - sticky, - survival -RoxygenNote: 6.1.1 -Suggests: - knitr, - rmarkdown, - testthat -VignetteBuilder: - knitr -LinkingTo: Rcpp +Package: GenEst +Title: Generalized Mortality Estimator +Version: 1.3.0 +Date: 2019-07-18 +Authors@R: c( + person("Daniel", "Dalthorp", , "ddalthorp@usgs.gov", c("aut", "cre")), + person("Juniper", "Simonis", , "simonis@dapperstats.com", "aut"), + person("Lisa", "Madsen", , "madsenl@oregonstate.edu", "aut"), + person("Manuela", "Huso", , "mhuso@usgs.gov", "aut"), + person("Paul", "Rabie", , "prabie@west-inc.com", "aut"), + person("Jeffrey", "Mintz", , "mintzj@oregonstate.edu", "aut"), + person("Robert", "Wolpert", , "wolpert@stat.duke.edu", "aut"), + person("Jared", "Studyvin", , "jstudyvin@west-inc.com", "aut"), + person("Franzi", "Korner-Nievergelt", , "fraenzi.korner@oikostat.ch", "aut")) +Description: Command-line and 'shiny' GUI implementation of the GenEst models for estimating bird and bat mortality at wind and solar power facilities, following Dalthorp, et al. (2018) <doi:10.3133/tm7A2>. +Depends: R (>= 3.5.0) +License: CC0 +Encoding: UTF-8 +LazyData: true +Imports: + cbinom (>= 1.3), + corpus, + DT, + gsl, + gtools, + htmltools, + lubridate, + matrixStats, + mvtnorm, + Rcpp, + shiny, + shinyjs, + sticky, + survival +RoxygenNote: 6.1.1 +Suggests: + knitr, + rmarkdown, + testthat +VignetteBuilder: + knitr +LinkingTo: Rcpp diff --git a/NAMESPACE b/NAMESPACE index 8259cd810e1b8db17fc45c14ee9559ac4518509b..dae61f7244e7a9a45f86fff498aa4f681a51b9db 100644 --- a/NAMESPACE +++ b/NAMESPACE @@ -24,6 +24,7 @@ S3method(summary,estM) S3method(summary,gGeneric) S3method(summary,gGenericSize) S3method(summary,splitFull) +export(CO_DWP) export(CPMainPanel) export(CPPanel) export(CPSidebar) @@ -105,12 +106,16 @@ export(disclaimersPanel) export(dlModTabCP) export(dlModTabSE) export(downloadCPFig) +export(downloadCPmod) export(downloadData) export(downloadMFig) +export(downloadMres) export(downloadSEFig) +export(downloadSEmod) export(downloadTable) export(downloadgFig) export(downloadsPanel) +export(dwpm) export(estM) export(estText) export(estg) @@ -200,6 +205,7 @@ export(prettyModTabCP) export(prettyModTabSE) export(prettySplitTab) export(rcp) +export(rdwp) export(reNULL) export(reVal) export(reaction) @@ -335,10 +341,10 @@ importFrom(stats,update.formula) importFrom(stats,weighted.mean) importFrom(survival,strata) importFrom(utils,combn) -importFrom(utils,globalVariables) importFrom(utils,packageDescription) importFrom(utils,read.csv) importFrom(utils,read.csv2) importFrom(utils,write.csv) +importFrom(utils,write.table) importFrom(utils,zip) useDynLib(GenEst, .registration = TRUE) diff --git a/R/GenEst.R b/R/GenEst.R index 0fa419bc36d3043c45a44cf16d25a9d365571a02..9c227b43b3398834d56dbc2691a2ecff4cc3b44a 100644 --- a/R/GenEst.R +++ b/R/GenEst.R @@ -20,7 +20,8 @@ #' formula median model.matrix na.omit optim pgamma pnorm qnorm quantile #' reformulate rnorm runif terms update.formula weighted.mean #' @importFrom survival strata -#' @importFrom utils combn packageDescription read.csv read.csv2 write.csv zip +#' @importFrom utils combn packageDescription read.csv read.csv2 write.csv +#' write.table zip #' #' @title Generalized estimation of mortality diff --git a/R/app_download_functions.R b/R/app_download_functions.R index 06baa1731f89955337f5da853a1773cf453de900..e253c6aaf379c4ffd76d6851e7bede042a394f4a 100644 --- a/R/app_download_functions.R +++ b/R/app_download_functions.R @@ -18,6 +18,64 @@ downloadCPFig <- function(rv){ ) } +#' @title Download summary of CP model fitting +#' +#' @description Handle the CP model downloading +#' +#' @param rv the reactive values list, +#' +#' @param input list of shiny input parameters +#' +#' @return a download handler function +#' +#' @export +#' +downloadCPmod <- function(rv, input){ + downloadHandler(filename = paste0(rv$filename_CP, "_CPmod.txt"), + content = function(file){ + cat(paste0("Data: ", rv$filename_CP), + c("\nLast present: ", rv$ltp, "\nFirst absent: ", rv$fta, "\n"), + file = file, sep = " ") + cat("Confidence level: ", 100 * rv$CL, "%\n\n", sep = "", file = file, append = TRUE) + selected_mods <- list() + modChoices <- list() + for (sci in 1:length(rv$sizeclasses)){ + selected_mods[[rv$sizeclasses[sci]]] <- paste0("dist: ", + gsub("constant", "1", input[[paste0("modelChoices_CP", sci)]])) + if (grepl("exponential", selected_mods[[rv$sizeclasses[sci]]])) + selected_mods[[sci]] <- paste0(selected_mods[[sci]], "; NULL") + modChoices[[rv$sizeclasses[sci]]] <- input[[paste0("modelChoices_CP", sci)]] + } + for (sci in rv$sizeclasses){ + nm <- ifelse(is.null(modChoices[[sci]]), "none selected", modChoices[[sci]]) + if (length(rv$sizeclasses) == 1){ + cat("Selected model: ", nm, "\n", file = file, append = TRUE) + } else { + cat("Selected model for", sci, ":", nm, "\n", file = file, append = TRUE) + } + if (!is.null(modChoices[[sci]])){ + suppressWarnings(write.table(rv$mods_CP[[sci]][[selected_mods[[sci]]]]$cell_ls, + row.names = FALSE, file = file, quote = FALSE, append = TRUE)) + } + cat("\n", file = file, append = TRUE) + } + cat("\nAIC Tables", file = file, append = TRUE) + aicTable <- aicc(rv$mods_CP) + for (sci in rv$sizeclasses){ + if (!(sci %in% names(aicTable))){ + cat("\n", sci, ": no model selected\n", file = file, append = TRUE) + } else { + cat("\n", sci, "\n", file = file, append = TRUE) + cat("l_formula s_formula AICc deltaAICc\n", file = file, append = TRUE) + suppressWarnings(write.table(aicTable[[sci]], + col.names = FALSE, row.names = TRUE, quote = FALSE, file = file, append = TRUE)) + cat("\n", file = file, append = TRUE) + } + } + } + ) +} + #' @title Download the SE figure #' #' @description Handle the SE figure downloading @@ -29,7 +87,7 @@ downloadCPFig <- function(rv){ #' @export #' downloadSEFig <- function(rv){ - downloadHandler(filename = "SE_fig.png", + downloadHandler(filename = paste0(rv$filename_SE, "_SEfig.png"), content = function(file){ png(file, height = rv$figH_SE, width = rv$figW_SE, units = "px") tryCatch( @@ -41,6 +99,63 @@ downloadSEFig <- function(rv){ ) } +#' @title Download summary of SE model fitting +#' +#' @description Handle the SE model downloading +#' +#' @param rv the reactive values list +#' +#' @param input the shiny input data +#' +#' @return a download handler function +#' +#' @export +#' +downloadSEmod <- function(rv, input){ + downloadHandler(filename = paste0(rv$filename_SE, "_SEmod.txt"), + content = function(file){ + cat("Data: ", rv$filename_SE, "\n", + "Observation columns: ", rv$obsCols_SE, "\n", + file = file, sep = " ") + cat("Confidence level: ", 100 * rv$CL, "%\n\n", sep = "", file = file, append = TRUE) + selected_mods <- list() + modChoices <- list() + for (sci in 1:length(rv$sizeclasses)){ + selected_mods[[rv$sizeclasses[sci]]] <- + gsub("constant", "1", input[[paste0("modelChoices_SE", sci)]]) + modChoices[[rv$sizeclasses[sci]]] <- input[[paste0("modelChoices_SE", sci)]] + } + for (sci in rv$sizeclasses){ + nm <- ifelse(is.null(modChoices[[sci]]), "none selected", modChoices[[sci]]) + if (length(rv$sizeclasses) == 1){ + cat("Selected model: ", nm, "\n", file = file, append = TRUE) + } else { + cat("Selected model for", sci, ":", nm, "\n", + file = file, append = TRUE) + } + if (!is.null(modChoices[[sci]])){ + suppressWarnings(write.table(rv$mods_SE[[sci]][[selected_mods[[sci]]]]$cell_pk, + row.names = FALSE, file = file, quote = FALSE, append = TRUE)) + } + cat("\n", file = file, append = TRUE) + } + cat("\nAIC Tables", file = file, append = TRUE) + aicTable <- aicc(rv$mods_SE) + for (sci in rv$sizeclasses){ + if (!(sci %in% names(aicTable))){ + cat("\n", sci, ": no model selected\n", file = file, append = TRUE) + } else { + cat("\n", sci, "\n", file = file, append = TRUE) + cat("p_formula k_formula AICc deltaAICc\n", file = file, append = TRUE) + suppressWarnings(write.table(aicTable[[sci]], + col.names = FALSE, row.names = TRUE, quote = FALSE, file = file, append = TRUE)) + cat("\n", file = file, append = TRUE) + } + } + } + ) +} + #' @title Download the g figure #' #' @description Handle the g figure downloading @@ -63,6 +178,115 @@ downloadgFig <- function(rv, sc){ ) } +#' @title Download M results (including SE and CP modeling) +#' +#' @description Handle the downloading of results +#' +#' @param rv the reactive values list +#' +#' @param input shiny input data +#' +#' @return a download handler function +#' +#' @export +#' +downloadMres <- function(rv, input){ + downloadHandler(filename = paste0(rv$filename_CO, "_Mres.txt"), + content = function(file){ + cat( + "SE Data: ", rv$filename_SE, "\n", + "CP Data: ", rv$filename_CP, "\n", + "SS Data: ", rv$filename_SS, "\n", + "DWP Data: ", rv$filename_DWP, "\n", + "CO Data: ", rv$filename_CO, "\n", + file = file, sep = "" + ) + cat("Confidence level: ", 100 * rv$CL, "%\n\n", sep = "", file = file, append = TRUE) + sumry <- summary(rv$Msplit, CL = rv$CL) + if (length(attr(rv$Msplit, "vars")) > 0) + cat("Estimated mortality by", paste(attr(rv$Msplit, "vars"), collapse = " and "), + "\n", file = file, append = TRUE) + else + cat("Estimated mortality \n", file = file, append = TRUE) + suppressWarnings(write.table(prettySplitTab(sumry), row.names = FALSE, + file = file, append = TRUE, quote = FALSE)) + cat("\n\nSearcher Efficiency\n", file = file, append = TRUE) + selected_mods <- list() + modChoices <- list() + for (sci in 1:length(rv$sizeclasses)){ + selected_mods[[rv$sizeclasses[sci]]] <- + gsub("constant", "1", input[[paste0("modelChoices_SE", sci)]]) + modChoices[[rv$sizeclasses[sci]]] <- input[[paste0("modelChoices_SE", sci)]] + } + for (sci in rv$sizeclasses){ + nm <- ifelse(is.null(modChoices[[sci]]), "none selected", modChoices[[sci]]) + if (length(rv$sizeclasses) == 1){ + cat("Selected model: ", nm, "\n", file = file, append = TRUE) + } else { + cat("Selected model for", sci, ":", nm, "\n", + file = file, append = TRUE) + } + if (!is.null(modChoices[[sci]])){ + suppressWarnings(write.table(rv$mods_SE[[sci]][[selected_mods[[sci]]]]$cell_pk, + row.names = FALSE, file = file, quote = FALSE, append = TRUE)) + } + cat("\n", file = file, append = TRUE) + } + cat("\nAIC Tables", file = file, append = TRUE) + aicTable <- aicc(rv$mods_SE) + for (sci in rv$sizeclasses){ + if (!(sci %in% names(aicTable))){ + cat("\n", sci, ": no model selected\n", file = file, append = TRUE) + } else { + cat("\n", sci, "\n", file = file, append = TRUE) + cat("p_formula k_formula AICc deltaAICc\n", file = file, append = TRUE) + suppressWarnings(write.table(aicTable[[sci]], + col.names = FALSE, row.names = TRUE, quote = FALSE, file = file, append = TRUE)) + cat("\n", file = file, append = TRUE) + } + } + + cat(c("\nCarcass persistence\nLast present: ", rv$ltp, "\nFirst absent: ", rv$fta, "\n"), + file = file, sep = " ") + selected_mods <- list() + modChoices <- list() + for (sci in 1:length(rv$sizeclasses)){ + selected_mods[[rv$sizeclasses[sci]]] <- paste0("dist: ", + gsub("constant", "1", input[[paste0("modelChoices_CP", sci)]])) + if (grepl("exponential", selected_mods[[rv$sizeclasses[sci]]])) + selected_mods[[sci]] <- paste0(selected_mods[[sci]], "; NULL") + modChoices[[rv$sizeclasses[sci]]] <- input[[paste0("modelChoices_CP", sci)]] + } + for (sci in rv$sizeclasses){ + nm <- ifelse(is.null(modChoices[[sci]]), "none selected", modChoices[[sci]]) + if (length(rv$sizeclasses) == 1){ + cat("Selected model: ", nm, "\n", file = file, append = TRUE) + } else { + cat("Selected model for", sci, ":", nm, "\n", file = file, append = TRUE) + } + if (!is.null(modChoices[[sci]])){ + suppressWarnings(write.table(rv$mods_CP[[sci]][[selected_mods[[sci]]]]$cell_ls, + row.names = FALSE, file = file, quote = FALSE, append = TRUE)) + } + cat("\n", file = file, append = TRUE) + } + cat("\nAIC Tables", file = file, append = TRUE) + aicTable <- aicc(rv$mods_CP) + for (sci in rv$sizeclasses){ + if (!(sci %in% names(aicTable))){ + cat("\n", sci, ": no model selected\n", file = file, append = TRUE) + } else { + cat("\n", sci, "\n", file = file, append = TRUE) + cat("l_formula s_formula AICc deltaAICc\n", file = file, append = TRUE) + suppressWarnings(write.table(aicTable[[sci]], + col.names = FALSE, row.names = TRUE, quote = FALSE, file = file, append = TRUE)) + cat("\n", file = file, append = TRUE) + } + } + } + ) +} + #' @title Download the M figure #' #' @description Handle the M figure downloading @@ -121,7 +345,8 @@ downloadTable <- function(filename, tablename, csvformat){ colnames(tablename) <- gsub("\u0394", "delta", colnames(tablename)) } downloadHandler(filename = filename, content = function(file){ - get(paste0("write.csv", csvformat))(x = tablename, file = file) + fcn <- get(paste0("write.csv", csvformat)) + fcn(x = tablename, file = file, row.names = FALSE) }) } diff --git a/R/app_panels.R b/R/app_panels.R index 0b1636c280a1d82a4243ba9b454c225eee6261a0..c4b6cbeeb8d6a52f07888c32f3fec151586bb95d 100644 --- a/R/app_panels.R +++ b/R/app_panels.R @@ -216,7 +216,9 @@ modelOutputPanel <- function(outType){ "SEModSelection" = list( em("Run models to select models"), - list(htmlOutput("modelMenu_SE")), + list(htmlOutput("modelMenu_SE"), br(), + downloadButton("dlSEmod", "Download") + ), NULL ), "CPFigures" = @@ -248,9 +250,10 @@ modelOutputPanel <- function(outType){ NULL ), "CPModSelection" = - list( + list( em("Run models to select models"), - list(htmlOutput("modelMenu_CP")), + list(htmlOutput("modelMenu_CP"), br(), + downloadButton("dlCPmod", "Download")), NULL ), "MFigures" = @@ -261,7 +264,14 @@ modelOutputPanel <- function(outType){ Carcass Persistence."), em("Run estimate to view figure"), list(plotOutput("fig_M", inline = TRUE), br(), br(), - downloadButton("dlMfig", "Download") + downloadButton("dlMfig", "Download"), + conditionalPanel( + condition = "output.MSplitDone == 'OK' & output.nMSplits > 1", + br(), br(), + radioButtons("cscale", "Common scale for y-axes?", + choices = c("Yes", "No"), + selected = "No") + ) ) ), "MSummary" = @@ -270,7 +280,7 @@ modelOutputPanel <- function(outType){ classes to run model"), em("Run estimate to view summary"), list(br(), dataTableOutput("table_M"), br(), - downloadButton("dlMtab", "Download") + downloadButton("dlMres", "Download") ) ), "gFigures" = diff --git a/R/app_server.R b/R/app_server.R index 13186a05c02c9ce915bb9813bf9f4ca8661e4e1d..be1ab0a565e63580664cef31f9fb83763fdb79fd 100644 --- a/R/app_server.R +++ b/R/app_server.R @@ -37,6 +37,7 @@ GenEstServer <- function(input, output, session){ msgs <- msgList() options(htmlwidgets.TOJSON_ARGS = list(na = 'string')) options(DT.options = list(pageLength = 25)) + options(stringsAsFactors = FALSE) observeEvent(input$clear_all, eval(reaction("clear_all"))) observeEvent(input$file_SE, eval(reaction("file_SE"))) observeEvent(input$file_SE_clear, eval(reaction("file_SE_clear"))) @@ -74,6 +75,7 @@ GenEstServer <- function(input, output, session){ observeEvent(input$split_M, eval(reaction("split_M"))) observeEvent(input$split_M_clear, eval(reaction("split_M_clear"))) observeEvent(input$transpose_split, eval(reaction("transpose_split"))) + observeEvent(input$cscale, eval(reaction("cscale"))) observeEvent(input$run_g, eval(reaction("run_g"))) observeEvent(input$run_g_clear, eval(reaction("run_g_clear"))) @@ -127,7 +129,7 @@ reaction <- function(eventName){ "split_M_clear", "transpose_split", "run_g", "run_g_clear", "outgclass", "load_RP", "load_RPbat", "load_cleared", "load_PV", - "load_trough", "load_powerTower", "load_mock") + "load_trough", "load_powerTower", "load_mock", "cscale") if (missing(eventName) || (eventName %in% eventOptions) == FALSE){ stop("eventName missing or not in list of available eventNames") @@ -221,26 +223,26 @@ reactionMessageDone <- function(eventName){ eventReaction <- function(eventName, rv, input, output, session){ if (eventName == "class"){ rv <- update_rv("run_SE_clear", rv, input) - output <- update_output("run_SE_clear", rv, output) + output <- update_output("run_SE_clear", rv, output, input) update_input("run_SE_clear", rv, input, session) rv <- update_rv("run_CP_clear", rv, input) - output <- update_output("run_CP_clear", rv, output) + output <- update_output("run_CP_clear", rv, output, input) update_input("run_CP_clear", rv, input, session) rv <- update_rv("run_M_clear", rv, input) - output <- update_output("run_M_clear", rv, output) + output <- update_output("run_M_clear", rv, output, input) update_input("run_M_clear", rv, input, session) rv <- update_rv("split_M_clear", rv, input) - output <- update_output("split_M_clear", rv, output) + output <- update_output("split_M_clear", rv, output, input) update_input("split_M_clear", rv, input, session) rv <- update_rv("run_g_clear", rv, input) - output <- update_output("run_g_clear", rv, output) + output <- update_output("run_g_clear", rv, output, input) update_input("run_g_clear", rv, input, session) rv <- update_rv(eventName, rv, input) - output <- update_output(eventName, rv, output) + output <- update_output(eventName, rv, output, input) update_input(eventName, rv, input, session) } else { rv <- update_rv(eventName, rv, input) - output <- update_output(eventName, rv, output) + output <- update_output(eventName, rv, output, input) update_input(eventName, rv, input, session) } } diff --git a/R/app_table_functions.R b/R/app_table_functions.R index 07859fbdd83eedddd1f3edf154ec513a93026dbf..0d3d9c5ee12169c3fff52c1dd3cc8fbaa00b93ee 100644 --- a/R/app_table_functions.R +++ b/R/app_table_functions.R @@ -67,11 +67,12 @@ dlModTabSE <- function(modTab, CL = 0.90){ } out <- modTab - lo <- 100 * (1 - CL) / 2 - up <- 100 - 100 * (1 - CL) / 2 - coltypes <- c("Median", paste0(lo, "%"), paste0(up, "%")) - colnames(out) <- c("Cell", "n", paste0("p ", coltypes), - paste0("k ", coltypes)) +# lo <- 100 * (1 - CL) / 2 +# up <- 100 - 100 * (1 - CL) / 2 +# coltypes <- c("Median", paste0(lo, "%"), paste0(up, "%")) + coltypes <- c("Median", (1 - CL)/2, 1 - (1 - CL)/2) + colnames(out) <- c("Cell", "n", paste0("p_", coltypes), + paste0("k_", coltypes)) return(out) } @@ -140,18 +141,19 @@ dlModTabCP <- function(modTabs, CL = 0.90){ modTab_d <- modTabs[["desc"]] ncell <- nrow(modTab) out <- modTab - lo <- 100 * (1 - CL) / 2 - up <- 100 - 100 * (1 - CL) / 2 - coltypes <- c("Median", paste0(lo, "%"), paste0(up, "%")) - colnames(out) <- c("Cell", "n", paste0("Location ", coltypes), - paste0("Scale ", coltypes)) +# lo <- 100 * (1 - CL) / 2 +# up <- 100 - 100 * (1 - CL) / 2 + coltypes <- c("Median",(1 - CL)/2, 1 - (1 - CL)/2) +# coltypes <- c("Median", paste0(lo, "%"), paste0(up, "%")) + colnames(out) <- c("Cell", "n", paste0("l_", coltypes), + paste0("s_", coltypes)) cellCol <- which(colnames(modTab_d) == "cell") out_d <- modTab_d[ , -cellCol] for (celli in 1:ncell){ cellMatch <- which(out$Cell == modTab_d$cell[celli]) out_d[celli, ] <- round(modTab_d[cellMatch, -cellCol], 2) } - colnames(out_d)[which(colnames(out_d) == "median")] <- "Median CP" + colnames(out_d)[which(colnames(out_d) == "median")] <- "Median_CP" out <- cbind(out, out_d) return(out) } diff --git a/R/app_ui.R b/R/app_ui.R index 1620e51b24b8d4e8e5586c7f71bfea49b0326738..8bcbb708a28496ee662bc68c1bc9adf0ad82fc4f 100644 --- a/R/app_ui.R +++ b/R/app_ui.R @@ -319,6 +319,7 @@ MSidebar <- function(){ sidebarPanel(width = 3, b(u(big("Model Inputs:"))), br(), br(), + modelInputWidget("xID"), modelInputWidget("frac"), modelInputWidget("DWPCol"), modelInputWidget("COdate"), diff --git a/R/app_update_input.R b/R/app_update_input.R index d21427e4a88af1e90b85518bcbe18202455262ce..28d1bb88e5716749e23fc7736af63c6d69aef516 100644 --- a/R/app_update_input.R +++ b/R/app_update_input.R @@ -34,7 +34,7 @@ update_input <- function(eventName, rv, input, session){ "split_M_clear", "transpose_split", "run_g", "run_g_clear", "outgclass", "load_RP", "load_RPbat", "load_cleared", "load_PV", - "load_trough", "load_powerTower", "load_mock") + "load_trough", "load_powerTower", "load_mock", "cscale") if (missing(eventName) || (eventName %in% eventOptions) == FALSE){ stop("eventName missing or not in list of available eventNames") @@ -76,6 +76,7 @@ update_input <- function(eventName, rv, input, session){ updateSelectizeInput(session, "outCPs", choices = "") updateSelectizeInput(session, "outCPdist", choices = "") updateSelectizeInput(session, "outCPclass", choices = "") + updateSelectizeInput(session, "xID", choices = "") updateSelectizeInput(session, "COdate", choices = "") updateNumericInput(session, "gSearchInterval", value = NULL) updateNumericInput(session, "gSearchMax", value = NULL) @@ -200,6 +201,8 @@ update_input <- function(eventName, rv, input, session){ } if (eventName == "file_CO"){ + updateSelectizeInput(session, "xID", choices = rv$colNames_xID, + selected = rv$colNames_xID[1]) updateSelectizeInput(session, "COdate", choices = rv$colNames_COdates) if (length(rv$colNames_COdates) == 1){ updateSelectizeInput(session, "COdate", choices = rv$colNames_COdates, @@ -238,6 +241,7 @@ update_input <- function(eventName, rv, input, session){ updateSelectizeInput(session, "ltp", choices = rv$colNames_ltp) updateSelectizeInput(session, "fta", choices = rv$colNames_fta) updateSelectizeInput(session, "class", choices = rv$colNames_size) + updateSelectizeInput(session, "xID", choices = rv$colNames_xID, selected = rv$xIDcol) updateSelectizeInput(session, "DWPCol", choices = rv$colNames_DWP) if (length(rv$colNames_DWP) == 1){ updateSelectizeInput(session, "DWPCol", selected = rv$colNames_DWP) @@ -424,6 +428,7 @@ update_input <- function(eventName, rv, input, session){ } if (eventName == "run_M"){ + updateSelectizeInput(session, "xID", choices = rv$colNames_xID, selected = rv$xIDcol) updateNumericInput(session, "frac", value = rv$frac) updateSelectizeInput(session, "split_SS", choices = rv$splittable_SS) updateSelectizeInput(session, "split_CO", choices = rv$colNames_CO) @@ -444,4 +449,3 @@ update_input <- function(eventName, rv, input, session){ updateSelectizeInput(session, "split_CO", choices = rv$colNames_CO) } } - diff --git a/R/app_update_output.R b/R/app_update_output.R index 8614ed9b9d0f822aa7289c15c2f18472f2a8f440..35662523b32f0411ed37d4efcfd95a51bfbdab81 100644 --- a/R/app_update_output.R +++ b/R/app_update_output.R @@ -18,11 +18,13 @@ #' #' @param output \code{output} list for the GenEst GUI. #' +#' @param input \code{input} lisst for the GenEst GUI +#' #' @return Updated \code{output} list. #' #' @export #' -update_output <- function(eventName, rv, output){ +update_output <- function(eventName, rv, output, input){ eventOptions <- c("clear_all", "file_SE", "file_SE_clear", "file_CP", "file_CP_clear", "file_SS", "file_SS_clear", "file_DWP", @@ -34,7 +36,7 @@ update_output <- function(eventName, rv, output){ "split_M_clear", "transpose_split", "run_g", "run_g_clear", "outgclass", "load_RP", "load_RPbat", "load_cleared", "load_PV", - "load_trough", "load_powerTower", "load_mock") + "load_trough", "load_powerTower", "load_mock", "cscale") if (missing(eventName) || (eventName %in% eventOptions) == FALSE){ stop("eventName missing or not in list of available eventNames") @@ -121,7 +123,7 @@ update_output <- function(eventName, rv, output){ toNULL <- c("filename_DWP", "data_DWP", "fig_M", "table_M", "MModDone") output <- reNULL(output, toNULL) if (eventName == "file_DWP"){ - output$data_DWP <- renderDTns(datatable(rv$data_DWP, + output$data_DWP <- renderDataTable(datatable(rv$data_DWP, caption = paste0("File: ", rv$filename_DWP))) output$filename_DWP <- renderText(paste0("File: ", rv$filename_DWP)) } @@ -279,12 +281,12 @@ update_output <- function(eventName, rv, output){ } else{ output$sizeclass_SEyn <- renderText("YES") } - output$dlSEest <- downloadTable("SE_estimates.csv", rv$modTabDL_SE, rv$csvformat) output$dlSEAICc <- downloadTable("SE_AICc.csv", rv$AICcTab_SE, rv$csvformat) output$dlSEfig <- downloadSEFig(rv) + output$dlSEmod <- downloadSEmod(rv, input) } dontSuspend <- c("text_SE_est", "MModDone", "gModDone", "sizeclass_gyn", "SEModDone", "kNeed", "DWPNeed", "sizeclasses_SE", @@ -313,9 +315,8 @@ update_output <- function(eventName, rv, output){ output$AICcTab_SE <- renderDataTable({rv$AICcTab_SE}) output$modTab_SE <- renderDataTable({rv$modTabPretty_SE}) output$fig_SE <- renderPlot({ - plot(rv$modSet_SE, specificModel = rv$best_SE, - app = TRUE) - }, height = rv$figH_SE, width = rv$figW_SE) + plot(rv$modSet_SE, specificModel = rv$best_SE, app = TRUE) + }, height = rv$figH_SE, width = rv$figW_SE) output$sizeclass_SE1 <- classText(rv, "SE") output$sizeclass_SE2 <- classText(rv, "SE") @@ -326,6 +327,7 @@ update_output <- function(eventName, rv, output){ output$dlSEAICc <- downloadTable("SE_AICc.csv", rv$AICcTab_SE, rv$csvformat) output$dlSEfig <- downloadSEFig(rv) + output$dlSEmod <- downloadSEmod(rv, input) } } @@ -339,6 +341,7 @@ update_output <- function(eventName, rv, output){ ) }, height = rv$figH_SE, width = rv$figW_SE) output$dlSEfig <- downloadSEFig(rv) + output$dlSEmod <- downloadSEmod(rv, input) if (!is.null(rv$modTab_SE)){ output$modTab_SE <- renderDataTable({rv$modTabPretty_SE}) output$dlSEest <- downloadTable("SE_estimates.csv", rv$modTabDL_SE, @@ -384,6 +387,7 @@ update_output <- function(eventName, rv, output){ output$dlCPAICc <- downloadTable("CP_AICc.csv", rv$AICcTab_CP, rv$csvformat) output$dlCPfig <- downloadCPFig(rv) + output$dlCPmod <- downloadCPmod(rv, input) } dontSuspend <- c("CPModDone", "sizeclasses_CP", "sizeclass_CPyn", "text_CP_est", "MModDone", "gModDone", "sizeclass_gyn") @@ -422,6 +426,7 @@ update_output <- function(eventName, rv, output){ output$dlCPAICc <- downloadTable("CP_AICc.csv", rv$AICcTab_CP, rv$csvformat) output$dlCPfig <- downloadCPFig(rv) + output$dlCPmod <- downloadCPmod(rv, input) } } @@ -438,7 +443,7 @@ update_output <- function(eventName, rv, output){ output$dlCPest <- downloadTable("CP_estimates.csv", rv$modTabDL_CP, rv$csvformat) output$dlCPfig <- downloadCPFig(rv) - + output$dlCPmod <- downloadCPmod(rv, input) if (!is.null(rv$modTab_CP)){ output$modTab_CP <- renderDataTable({rv$modTabPretty_CP}) output$dlCPest <- downloadTable("CP_estimates.csv", rv$modTabDL_CP, @@ -513,8 +518,7 @@ update_output <- function(eventName, rv, output){ output$sizeclass_g1 <- scText output$sizeclass_g2 <- scText - output$dlgtab <- downloadTable("g_estimates.csv", summaryTab, - rv$csvformat) + output$dlgtab <- downloadTable("g_estimates.csv", summaryTab, rv$csvformat) output$dlgfig <- downloadgFig(rv, rv$sizeclass_g) } } @@ -524,13 +528,13 @@ update_output <- function(eventName, rv, output){ output <- reNULL(output, toNULL) if (!is.null(rv$Msplit)){ output$MModDone <- renderText("OK") - output$fig_M <- renderPlot({plot(rv$Msplit, CL = rv$CL)}, - height = rv$figH_M, width = rv$figW_M - ) + output$fig_M <- renderPlot({ + plot(rv$Msplit, CL = rv$CL,)}, height = rv$figH_M, width = rv$figW_M) summaryTab <- prettySplitTab(summary(rv$Msplit, CL = rv$CL)) output$table_M <- renderDataTable(datatable(summaryTab)) - output$dlMtab <- downloadTable("M_table.csv", summaryTab, rv$csvformat) + #output$dlMtab <- downloadTable("M_table.csv", summaryTab, rv$csvformat) output$dlMfig <- downloadMFig(rv) + output$dlMres <- downloadMres(rv, input) } outputOptions(output, "MModDone", suspendWhenHidden = FALSE) } @@ -542,7 +546,6 @@ update_output <- function(eventName, rv, output){ } if (eventName == "split_M"){ - if (is.null(rv$Msplit)){ output$fig_M <- renderPlot({ tryCatch(plot(rv$M, CL = rv$CL), @@ -551,13 +554,12 @@ update_output <- function(eventName, rv, output){ }, height = rv$figH_M, width = rv$figW_M) output$dlMfig <- downloadMFig(rv, split = FALSE) - } else{ + } else { output$fig_M <- renderPlot({ - tryCatch(plot(rv$Msplit, CL = rv$CL), - error = function(x){plotNA("split")} - ) - }, height = rv$figH_M, width = rv$figW_M - ) + tryCatch(plot(summary(rv$Msplit), CL = rv$CL, commonScale = input$cscale == "Yes"), + error = function(x){plotNA("split")} + ) + }, height = rv$figH_M, width = rv$figW_M) tmp <- prettySplitTab(summary(rv$Msplit, CL = rv$CL)) summaryTab <- data.frame(tmp, stringsAsFactors = FALSE) names(summaryTab) <- colnames(tmp) @@ -566,9 +568,9 @@ update_output <- function(eventName, rv, output){ if (!anyNA(testcol)) summaryTab[, sti] <- testcol } output$table_M <- renderDataTable(datatable(summaryTab)) - output$dlMtab <- downloadTable("M_table.csv", summaryTab, - rv$csvformat) + #output$dlMtab <- downloadTable("M_table.csv", summaryTab, rv$csvformat) output$dlMfig <- downloadMFig(rv) + output$dlMres <- downloadMres(rv, input) } output$MSplitDone <- renderText("OK") output$nMSplits <- renderText( @@ -576,9 +578,13 @@ update_output <- function(eventName, rv, output){ outputOptions(output, "nMSplits", suspendWhenHidden = FALSE) outputOptions(output, "MSplitDone", suspendWhenHidden = FALSE) } - + if (eventName == "cscale"){ + commonScale <- input$cscale == "Yes" + output$fig_M <- renderPlot({ + plot(summary(rv$Msplit), CL = rv$CL, commonScale = commonScale)}, + height = rv$figH_M, width = rv$figW_M) + } if (eventName == "split_M_clear"){ - if (!is.null(rv$Msplit)){ output$MModDone <- renderText("OK") outputOptions(output, "MModDone", suspendWhenHidden = FALSE) @@ -588,8 +594,9 @@ update_output <- function(eventName, rv, output){ ) summaryTab <- prettySplitTab(summary(rv$Msplit, CL = rv$CL)) output$table_M <- renderDataTable(datatable(summaryTab)) - output$dlMtab <- downloadTable("M_table.csv", summaryTab, rv$csvformat) + #output$dlMtab <- downloadTable("M_table.csv", summaryTab, rv$csvformat) output$dlMfig <- downloadMFig(rv) + output$dlMres <- downloadMres(rv, input) } output$MSplitDone <- NULL @@ -601,11 +608,11 @@ update_output <- function(eventName, rv, output){ if (eventName == "transpose_split"){ if (!is.null(rv$Msplit)){ output$fig_M <- renderPlot({ - tryCatch(plot(rv$Msplit, CL = rv$CL), - error = function(x){plotNA("split")} - ) - }, height = rv$figH_M, width = rv$figW_M - ) + tryCatch( + plot(summary(rv$Msplit), CL = rv$CL, commonScale = input$cscale == "Yes"), + error = function(x){plotNA("split")} + ) + }, height = rv$figH_M, width = rv$figW_M) output$dlMfig <- downloadMFig(rv, TRUE) } } diff --git a/R/app_update_rv.R b/R/app_update_rv.R index 9d21f1a1c02871380a2631c7d5255fd2123e9791..29f58d489a3debedc02ecb49f5967b8ec35c37c9 100644 --- a/R/app_update_rv.R +++ b/R/app_update_rv.R @@ -35,7 +35,7 @@ update_rv <- function(eventName, rv, input){ "split_M_clear", "transpose_split", "run_g", "run_g_clear", "outgclass", "load_RP", "load_RPbat", "load_cleared", "load_PV", - "load_trough", "load_powerTower", "load_mock") + "load_trough", "load_powerTower", "load_mock", "cscale") if (missing(eventName) || (eventName %in% eventOptions) == FALSE){ stop("eventName missing or not in list of available eventNames") @@ -257,13 +257,16 @@ update_rv <- function(eventName, rv, input){ if (eventName == "file_CO"){ toNULL <- c("data_CO", "filename_CO", "colNames_CO", "colNames_COdates", - "M", "Msplit", "unitCol", "sizeCol_M", "SEmodToUse", "split_CO", + "M", "Msplit", "xID", "unitCol", "sizeCol_M", "SEmodToUse", "split_CO", "split_SS") rv <- reNULL(rv, toNULL) toReVal <- c("nsplit_CO", "nsplit_SS", "figH_M", "figW_M") rv <- reVal(rv, toReVal) rv$data_CO <- readCSV(input$file_CO$datapath) rv$filename_CO <- input$file_CO$name + rv$colNames_xID <- names(which( + apply(rv$data_CO, FUN = function(x) length(unique(x)), MARGIN = 2) == + apply(rv$data_CO, FUN = length, MARGIN = 2))) rv$colNames_CO <- colnames(rv$data_CO) rv$colNames_COdates <- dateCols(rv$data_CO) rv$colNames_size0 <- updateColNames_size(rv) @@ -397,6 +400,10 @@ update_rv <- function(eventName, rv, input){ rv$colNames_size0 <- updateColNames_size(rv) rv$colNames_size <- rv$colNames_size0 + rv$colNames_xID <- names(which( + apply(rv$data_CO, FUN = function(x) length(unique(x)), MARGIN = 2) == + apply(rv$data_CO, FUN = length, MARGIN = 2))) + rv$xIDcol <- rv$colNames_xID[1] rv$sizeCol <- NULL } if (eventName == "class"){ @@ -548,8 +555,7 @@ update_rv <- function(eventName, rv, input){ rv$sizeclasses_SE <- sort(rv$sizeclasses) rv$sizeclass <- pickSizeclass(rv$sizeclasses, input$outSEclass) rv$sizeclass_SE <- rv$sizeclass - rv$AICcTab_SE <- aicc(rv$mods_SE[[rv$sizeclass_SE]], quiet = TRUE, - app = TRUE) + rv$AICcTab_SE <- aicc(rv$mods_SE[[rv$sizeclass_SE]], quiet = TRUE, app = TRUE) rv$modOrder_SE <- as.numeric(row.names(rv$AICcTab_SE)) rv$modNames_SE <- names(rv$mods_SE[[rv$sizeclass_SE]])[rv$modOrder_SE] rv$modNames_SEp <- modNameSplit(rv$modNames_SE, 1) @@ -864,6 +870,7 @@ update_rv <- function(eventName, rv, input){ } rv$COdate <- input$COdate rv$nsim <- input$nsim + rv$xIDcol <- input$xID rv$frac <- input$frac if (rv$frac < 0.01 | rv$frac > 1) return(rv) rv$SEmodToUse <- rep(NA, rv$nsizeclasses) diff --git a/R/app_utilities.R b/R/app_utilities.R index 27222e2afef86f6e4b100a379e8e8e575042a156..88325b8e71dfa9a8f34024500e07af859f047a48 100644 --- a/R/app_utilities.R +++ b/R/app_utilities.R @@ -14,6 +14,9 @@ #' @export #' reVal <- function(rv, toReVal){ + if("xID" %in% toReVal){ + rv$colnames_xID <- NULL + } if("nsplit_CO" %in% toReVal){ rv$nsplit_CO <- 0 } @@ -571,6 +574,7 @@ plotNA <- function(type = "model"){ badText <- "Selected model was not fit successfully." } if (type == "split"){ +cat("in plotNA...\n") badText <- "Second split too fine for plotting. Consider transposing." } plot(1, 1, type = "n", xaxt = "n", yaxt = "n", bty = "n", xlab = "", @@ -610,11 +614,11 @@ initialReactiveValues <- function(){ sizeCol = NULL, toRemove_sizeCol = NULL, sizeclasses = NULL, sizeclass = NULL, sizeclass_SE = NULL, - sizeclass_CP = NULL, sizeclass_g = NULL, sizeclass_M = NULL, + sizeclass_CP = NULL, sizeclass_g = NULL, sizeclass_M = NULL, nsizeclasses = 0, obsCols_SE = NULL, preds_SE = NULL, predictors_SE = NULL, - formula_p = NULL, formula_k = NULL, kFixedChoice = NULL, kFixed = NULL, + formula_p = NULL, formula_k = NULL, kFixed = NULL, mods_SE = NULL, mods_SE_og = NULL, sizeclasses_SE = NULL, outSEpk = NULL, AICcTab_SE = NULL, modOrder_SE = NULL, modNames_SE = NULL, modNames_SEp = NULL, modNames_SEk = NULL, modSet_SE = NULL, @@ -631,8 +635,8 @@ initialReactiveValues <- function(){ best_CP = NULL, modTab_CP = NULL, modTabPretty_CP = NULL, modTabDL_CP = NULL, figH_CP = 700, figW_CP = 800, - M = NULL, Msplit = NULL, unitCol = NULL, frac = 1, - sizeCol_M = NULL, DWPCol = NULL, COdate = NULL, + M = NULL, Msplit = NULL, unitCol = NULL, colNames_xID = NULL, xIDcol = NULL, + frac = 1, sizeCol_M = NULL, DWPCol = NULL, COdate = NULL, SEmodToUse = NULL, CPmodToUse = NULL, split_CO = NULL, split_SS = NULL, nsplit_CO = 0, nsplit_SS = 0, figH_M = 600, figW_M = 800, diff --git a/R/app_widgets.R b/R/app_widgets.R index 705eafb506dff84983512a5a6e594275251b487f..c5254276b083ec252d4e1a611f6f5729b4c47fa2 100644 --- a/R/app_widgets.R +++ b/R/app_widgets.R @@ -99,7 +99,7 @@ dataDownloadWidget <- function(set){ #' #' @param inType Toggle control for the input type of the widget. One of #' "nsim", "CL", "class", "obsSE", "predsSE", "kFixed", "ltp", "fta", -#' "predsCP", "dist", "frac", "DWPCol", "COdate", "gSearchInterval", or +#' "predsCP", "dist", "xID", "frac", "DWPCol", "COdate", "gSearchInterval", or #' "gSearchMax". #' #' @return HTML for the model input widget. @@ -110,7 +110,7 @@ modelInputWidget <- function(inType){ if (!inType %in% c("nsim", "CL", "class", "obsSE", "predsSE", "kFixedInput", "ltp", "fta", "predsCP", "dist", - "frac", "DWPCol", "COdate", + "xID", "frac", "DWPCol", "COdate", "gSearchInterval", "gSearchMax")){ stop(paste0("input inType (", inType, ") not supported")) } @@ -118,9 +118,9 @@ modelInputWidget <- function(inType){ Name <- inType Label <- switch(inType, - "nsim" = "Number of Iterations:", + "nsim" = "Number of Iterations:", "CL" = "Confidence Level:", - "class" = "Size Class Column (optional):", + "class" = "Carcass Class Column (optional):", "obsSE" = "Observations:", "predsSE" = "Predictor Variables:", "kFixedInput" = NULL, @@ -128,14 +128,15 @@ modelInputWidget <- function(inType){ "fta" = "First Time Absent:", "predsCP" = "Predictor Variables:", "dist" = "Distributions to Include", - "frac" = "Fraction of Facility Surveyed:", - "DWPCol" = "Density Weighted Proportion:", + "xID" = "Carcass ID Column (CO)", + "frac" = "Fraction of Facility Surveyed:", + "DWPCol" = "Density Weighted Proportion:", "COdate" = "Date Found:", "gSearchInterval" = "Search Interval (days):", "gSearchMax" = "Total Span of Monitoring (days):") widgetFun <- switch(inType, - "nsim" = "numericInput", + "nsim" = "numericInput", "CL" = "numericInput", "class" = "selectizeInput", "obsSE" = "selectizeInput", @@ -145,15 +146,16 @@ modelInputWidget <- function(inType){ "fta" = "selectizeInput", "predsCP" = "selectizeInput", "dist" = "checkboxGroupInput", - "frac" = "numericInput", - "DWPCol" = "selectizeInput", + "xID" = "selectizeInput", + "frac" = "numericInput", + "DWPCol" = "selectizeInput", "COdate" = "selectizeInput", "gSearchInterval" = "numericInput", "gSearchMax" = "numericInput") Args <- switch(inType, - "nsim" = list(value = 1000, min = 1, max = 10000, step = 1), - "CL" = list(value = 0.90, min = 0, max = 1, step = 0.001), + "nsim" = list(value = 1000, min = 1, max = 10000, step = 1), + "CL" = list(value = 0.90, min = 0, max = 0.999, step = 0.001), "class" = list(c("No data input yet"), multiple = TRUE, options = list(maxItems = 1)), "obsSE" = list(c("No SE data input yet"), multiple = TRUE), @@ -166,8 +168,10 @@ modelInputWidget <- function(inType){ "predsCP" = list(c("No CP data input yet"), multiple = TRUE), "dist" = list(choices = CPdistOptions(), selected = unlist(CPdistOptions()), inline = TRUE), + "xID" = list(c("No carcass data input yet"), multiple = TRUE, + options = list(maxItems = 1)), "frac" = list(value = 1.0, min = 0.01, max = 1.0, step = 0.01), - "DWPCol" = list(c("No DWP data input yet"), multiple = TRUE, + "DWPCol" = list(c("No DWP data input yet"), multiple = TRUE, options = list(maxItems = 1)), "COdate" = list(c("No carcass data input yet"), multiple = TRUE, options = list(maxItems = 1)), @@ -185,8 +189,9 @@ modelInputWidget <- function(inType){ "fta" = NULL, "predsCP" = NULL, "dist" = NULL, - "frac" = NULL, - "DWPCol" = "output.DWPNeed == 'yes'", + "xID" = NULL, + "frac" = NULL, + "DWPCol" = "output.DWPNeed == 'yes'", "COdate" = NULL, "gSearchInterval" = NULL, "gSearchMax" = NULL) @@ -199,7 +204,7 @@ modelInputWidget <- function(inType){ #' #' @description Basic generalized function for creating an input widget based #' on the condition of the widget being presented, the name of the widget, -#' the function used to create it, it's label on the UI, and any additional +#' the function used to create it, its label on the UI, and any additional #' arguments. #' #' @param Condition Condition under which the widget is present to the user. @@ -332,7 +337,8 @@ preTextMaker <- function(modType){ Condition <- switch(modType, "SE" = "input.obsSE == null", "CP" = "input.ltp == null | input.fta == null", - "M" = c("input.modelChoices_SE1 == null | + "M" = c("input.xID == null", + "input.modelChoices_SE1 == null | input.modelChoices_CP1 == null | output.sizeclasses_SE != output.sizeclasses_CP", "output.filename_SS == null", @@ -340,7 +346,7 @@ preTextMaker <- function(modType){ input.modelChoices_CP1 != null & output.sizeclasses_SE == output.sizeclasses_CP & (input.DWPCol == null | input.COdate == null)", - "output.kNeed == 'yes' & + "output.kNeed == 'yes' & input.modelChoices_SE1 != null"), "g" = c("input.modelChoices_SE1 == null | input.modelChoices_CP1 == null | @@ -352,11 +358,12 @@ preTextMaker <- function(modType){ Text <- switch(modType, "SE" = "Select observation columns to run model", "CP" = "Select observation columns to run model", - "M" = c("Select SE and CP models fit to matching size classes to + "M" = c("Select carcass ID column to run model", + "Select SE and CP models fit to matching size classes to run model", "Input Search Schedule data to run model", "Select input columns to run model", - "A value for k is required to estimate mortality. + "A value for k is required to estimate mortality. Return to Search Efficiency tab and fix k."), "g" = c("Select SE and CP models fit to matching size classes to run model", @@ -366,8 +373,7 @@ preTextMaker <- function(modType){ out <- vector("list", length(Condition)) for (i in 1:length(Condition)){ - out[[i]] <- conditionalPanel(condition = Condition[i], - br(), center(em(Text[i]))) + out[[i]] <- conditionalPanel(condition = Condition[i], br(), center(em(Text[i]))) } out } diff --git a/R/detection_probability_functions.R b/R/detection_probability_functions.R index 4eafdf7c67a92a92af93b4d8abb21c03a5c33390..bbb16e58aef7199b924f840660890ebacc4491fd 100644 --- a/R/detection_probability_functions.R +++ b/R/detection_probability_functions.R @@ -15,8 +15,13 @@ #' @param model_CP Carcass Persistence model (or list of models if there are #' multiple size classes) #' +#' @param model_DWP Density weighted proportion model (or list of models if +#' there are multiple size classes) +#' #' @param unitCol Column name for the unit indicator #' +#' @param IDcol Column name for unique carcass IDs (required) +#' #' @param SSdate Column name for the date searched data. Optional. #' If not provided, \code{estg} will try to find the SSdate among #' the columns in data_SS. See \code{\link{prepSS}}. @@ -59,7 +64,8 @@ #' @export #' estg <- function(data_CO, COdate, data_SS, SSdate = NULL, - model_SE, model_CP, sizeCol = NULL, unitCol = NULL, + model_SE, model_CP, model_DWP = NULL, + sizeCol = NULL, unitCol = NULL, IDcol = NULL, nsim = 1000, max_intervals = 8, seed_SE = NULL, seed_CP = NULL, seed_g = NULL){ i <- sapply(data_CO, is.factor) @@ -70,6 +76,19 @@ estg <- function(data_CO, COdate, data_SS, SSdate = NULL, # error-checking if (is.null(unitCol)) unitCol <- defineUnitCol(data_CO = data_CO, data_SS = data_SS) + if (is.null(IDcol)){ + IDcol <- names(which( + apply(data_CO, FUN = function(x) length(unique(x)), MARGIN = 2) == + apply(data_CO, FUN = length, MARGIN = 2))) + if (length(IDcol) == 0){ + stop("CO data must include unique identifier for each caracass") + } else if (length(IDcol) > 1) { + stop("Carcass ID column must be specified in CO data") + } + } else { + if (length(data_CO[ , IDcol]) != unique(length(data_CO[ , IDcol]))) + stop(paste0("Carcass IDs are not unique (in CO, column ", IDcol, ")")) + } SSdat <- prepSS(data_SS) # SSdat name distinguishes this as pre-formatted if (any(! data_CO[, unitCol] %in% SSdat$unit)) stop("carcasses found (CO) at units not properly formatted (or missing) in SS") @@ -365,12 +384,67 @@ estg <- function(data_CO, COdate, data_SS, SSdate = NULL, } } } - + if (is.null(model_DWP)) { + DWP <- 1 + } else { + dwpsim <- rdwp(n = nsim, model = model_DWP) + if (length(dwpsim) == 1){ + DWP <- 1 + } else { + DWP <- CO_DWP(dwpsim = dwpsim, data_CO = data_CO, unitCol = unitCol, sizeCol = sizeCol) + } + } rownames(Aj) <- COdat[ , unitCol] - out <- list("ghat" = ghat, "Aj" = Aj) # ordered by relevance to user + rownames(ghat) <- COdat[ , IDcol] + out <- list("ghat" = ghat, "Aj" = Aj, "DWP" = DWP) # ordered by relevance to user return(out) } +#' @title Associate CO carcasses with appropriate DWP values (by unit and carcass class) +#' +#' @description Calculate the conditional probability of observing a carcass +#' at search oi as a function arrival interval (assuming carcass is not +#' removed by scavengers before the time of the final search) +#' +#' @param dwpsim \code{rdwp} object +#' +#' @param data_CO data frame with results from carcass surveys +#' +#' @param unitCol name of the unit column in data_CO (required) +#' +#' @param sizeCol name of the size column in data_CO (optional). +#' +#' @return numeric DWP array +#' +#' @export +#' +CO_DWP <- function(dwpsim, data_CO, unitCol, sizeCol = NULL){ + if (!"rdwp" %in% class(dwpsim)) + stop("dwpsim must be of class 'rdwp'") + if (!unitCol %in% names(data_CO)) + stop("unitCol must be the name of a valid unit column in data_CO") + if (length(unitCol) > 1) + stop("unitCol must be the name of a unique, valid unit column in data_CO") + + if (is.null(sizeCol) || sizeCol == "placeholder"){ + if (is.list(dwpsim)) + stop("dwpsim should be an array rather than a list when no sizeCol is provided") + if (!all(data_CO[ , unitCol] %in% row.names(dwpsim))) + stop("some units in data_CO not represented in dwpsim") + DWP <- dwpsim[match(data_CO[, unitCol], row.names(dwpsim)), ] + } else { + if (!sizeCol %in% names(data_CO)) + stop("sizeCol not in data_CO") + if (!is.list(dwpsim) || !all(data_CO[ , sizeCol] %in% names(dwpsim))) + stop("dwpsim must be a list to match sizes in data_CO[ , sizeCol]") + DWP <- array(dim = c(nrow(data_CO), ncol(dwpsim[[1]]))) + for (ci in 1:nrow(data_CO)){ + DWP[ci, ] <- dwpsim[[data_CO[ci, sizeCol]]][data_CO[ci, unitCol], ] + } + } + if (NCOL(DWP) == 1) DWP <- as.vector(DWP) + return(DWP) +} #' @title Calculate conditional probability of observation at a search #' #' @description Calculate the conditional probability of observing a carcass @@ -618,7 +692,7 @@ calcg <- function(days, param_SE, param_CP, dist){ pfind.si <- nvec * powk diffs <- cbind(schedule[,2] - schedule[,1], schedule[,3] - schedule[,2]) - intxsearch <- unique(diffs, MAR = 1) + intxsearch <- unique(diffs, MARGIN = 1) ppersu <- ppersist(dist = dist, t_arrive0 = 0, t_arrive1 = intxsearch[,1], t_search = intxsearch[,1] + intxsearch[,2], pda = pda0, pdb = pdb0) arrvec <- (schedule[,2] - schedule[,1]) / max(days) @@ -651,7 +725,7 @@ calcg <- function(days, param_SE, param_CP, dist){ pfind.si <- pk[ , 1] * powk * cbind(rep(1, n), matrixStats::rowCumprods(val)) } diffs <- cbind(schedule[,2] - schedule[,1], schedule[,3] - schedule[,2]) - intxsearch <- unique(diffs, MAR = 1) + intxsearch <- unique(diffs, MARGIN = 1) ppersu <- ppersist(dist = dist, t_arrive0 = 0, t_arrive1 = intxsearch[ , 1], t_search = intxsearch[ , 1] + intxsearch[ , 2], pda = param_CP[ , 1], pdb = param_CP[ , 2] diff --git a/R/dwp_functions.R b/R/dwp_functions.R new file mode 100644 index 0000000000000000000000000000000000000000..b3577944847253bb1a131b137aebf09f52591177 --- /dev/null +++ b/R/dwp_functions.R @@ -0,0 +1,202 @@ +#' @title Fit density-weighted proportion (DWP) models. +#' +#' @description Carcass density is modeled as a function of distance from +#' turbine. Format and usage parallel that of common \code{R} functions +#' \code{lm}, \code{glm}, and \code{gam} and the GenEst functions \code{pkm} +#' and \code{cpm}. +#' +#' @details The fraction of carcasses falling in the area searched at a turbine +#' may be a function of carcass class (e.g., large or small) and/or direction +#' from the turbine. Data may be provided for fitting a distance model(s) or, +#' alternatively, simulated turbine-wise DWP data from custom-fitted models may +#' be provided. If pre-fit, pre-simulated data are used, then \code{glm} returns +#' a \code{dwpm} object with \code{type = data}. +#' +#' To fit a model, \code{data_DWP} should be a data frame with a row for each carcass +#' and columns giving (at a minimum) unique carcass IDs, turbine ID, distance +#' from turbine, and fraction of area searched at the given distance at the +#' given turbine. Optional columns may include size class, covariates that may +#' influence detection probability (e.g., visibility class), and direction. +#' If covariates are to be included in the model, then the fraction of area +#' column would give the fraction of the area in the given covariate level at +#' that distance. Alternatively, prefab data may be provided in a dataframe, +#' with structure depending on data type. The simplest case would be that +#' point estimates only are provided. In that case, if there are no distinctions +#' among carcass classes (e.g., size), then \code{data_DWP} should be a dataframe +#' with one column giving the unit (e.g., turbine) and one column with the DWP +#' at each unit; if distinctions are made among sizes, then \code{data_DWP} would +#' be a data frame with a unit column and a DWP column for each size class. If +#' the DWP estimates incorporate uncertainties, then \code{data_DWP} should be +#' an array with \code{n_unit * nsim} rows and with colunms for units and DWPs for +#' each carcass class. +#' +#' @param data_DWP data frame with structure depending on model +#' type. In general, \code{data_DWP} would be a data frame if a model is to be +#' fit or if point estimates only are provided as pre-simulated DWP data, and, +#' if pre-simulated data with variation are provided, then a 2-d array (if one +#' carcass class) or a list of 2-d arrays (if more than one carcass class). See +#' "Details" for details. +#' +#' @param type model type may be \code{rings}, \code{glm}, \code{TWL}, or +#' \code{data}. Currently, only the \code{data} type is supported. +#' +#' @param unitCol name of the column with the units, which must be non-numeric +#' +#' @param dwpCols name(s) of the columns with the DWP data +#' +#' @return an object of an object of class \code{dwpm}, which is a list with +#' model \code{type} (currently only \code{type = data} is supported) and +#' \code{model}, which gives the simulated DWP values as an array (if there's +#' only a single carcass class) or a list of arrays (if there are more than one +#' carcass classes). +#' +#' @export +#' +dwpm <- function(data_DWP, type = "data", unitCol = NULL, dwpCols = NULL){ + if (is.null(data_DWP)){ + message("data_DWP missing. Returning DWP = 1.") + out <- 1 + attr(out, "type") <- "data" + class(out) <- "dwpm" + return(out) + } + if (!type %in% "data") stop("\"", type, "\" DWP model type not supported.") + if (!"data.frame" %in% class(data_DWP)) stop("data_DWP must be a data frame") + if (type %in% "data"){ + numericColumns <- which(unlist(lapply(data_DWP, + function(x) is.numeric(x) & !any(is.na(x))))) + # check unitCol + if (!is.null(unitCol)){ # check format of user-provided unitCol + if (length(unitCol) > 1) + stop("unitCol must be the name of a single column in data_DWP") + if (!unitCol %in% names(data_DWP)) + stop("unitCol (", unitCol, ") not in data_DWP") + if (is.numeric(unitCol)) + stop("unitCol must be non-numeric") + unittab <- table(data_DWP[ , unitCol]) + if (length(unique(unittab)) > 1) + stop("Each unit in unitCol must have the same number of reps") + nsim <- unittab[1] +# if (nsim > 1 & !"rep" %in% names(data_DWP)) +# stop("data_DWP must have 'rep' column if units are represented more than once ") +# if (nsim > 1){ +# if (!all(table(data_DWP[ , c("rep", unitCol)]) == 1)) +# stop("All units must be represented exactly once in each rep") +# } + } else { # identify the unitCol when user has not provided ore + if (length(names(data_DWP)) > length(numericColumns) + 1){ + stop("more than one potential unitCol in data_DWP = ", + deparse(substitute(data_DWP)), ". A unique unitCol must be provided.") + } else if (length(names(data_DWP)) == length(numericColumns)) { + stop("A non-numeric unit column (unitCol) must be present in data_DWP") + } else { + unitCol <- names(data_DWP)[-numericColumns] + } + unittab <- table(data_DWP[ , unitCol]) + if (length(unique(unittab)) > 1) + stop("unitCol = NULL but no suitable unit column found in data_DWP ", + "(all units must have the same number of reps)") + nsim <- unittab[1] +# if (nsim > 1 & !"rep" %in% names(data_DWP)) # not really necessary to have a "rep" column +# stop("data_DWP must have 'rep' column if units are represented more than once ") +# if (nsim > 1){ # a check to ensure that each unit is represented in each rep...not necessary +# if (!all(table(data_DWP[ , c("rep", unitCol)]) == 1)) +# stop("No suitable unit column found") +# } + } + + unitNames <- unique(data_DWP[ , unitCol]) + + # check dwpCols + if (!is.null(dwpCols)){ # quick check format of user-provided unitCol + if (any(!dwpCols %in% names(data_DWP))){ + stop("some dwpCols not in data_DWP") + } + } else { # identify dwpCols if not provided + for (i in numericColumns){ + if (sum(data_DWP[ , i] <= 0 | data_DWP[ , i] > 1) == 0) + dwpCols <- c(dwpCols, names(data_DWP[i])) + } + if (length(dwpCols) == 0) + stop(data_DWP, " must contain a DWP column of values in (0, 1]") + } + + # construct output structure: matrix if no carcass class distinctions; list otherwise + if (length(dwpCols) == 1){ # no carcass classes --> matrix + dwpmat <- array(dim = c(length(unitNames), nsim)) + row.names(dwpmat) <- unitNames + if (nsim == 1){ + dwpmat[ , 1] <- data_DWP[ , dwpCols] + } else { + for (ui in unitNames){ + dwpmat[ui , ] <- data_DWP[data_DWP[ , unitCol] == ui, dwpCols] + } + } + out <- dwpmat + } else { # more than one carcass class --> list of dwpmat's + out <- list() + dwpmat <- array(dim = c(length(unitNames), nsim)) + row.names(dwpmat) <- unitNames + for (di in dwpCols){ + if (nsim == 1){ + dwpmat[ , 1] <- data_DWP[ , di] + } else { + for (ui in unitNames){ + dwpmat[ui , ] <- data_DWP[data_DWP[ , unitCol] == ui, di] + } + } + out[[di]] <- dwpmat + } + } + } + attr(out, "type") <- type + class(out) <- "dwpm" + return(out) +} + + +#' @title Simulate parameters from a fitted dwp model +#' +#' @description Simulate parameters from a \code{\link{dwpm}} model object +#' +#' @details If the model type = \code{data}, then the number of simulated columns +#' must be either \code{>=n} (in which case the first n colunms are taken as the +#' simulated DWP) or 1 (in which case, DWP is assumed constant). +#' +#' @param n the number of simulation draws +#' +#' @param model A \code{\link{dwpm}} object (which is returned from +#' \code{dwpm()}) +#' +#' @return array of \code{n} simulated \code{dwp} values for each unit. +#' Dimensions = c(n, number of units). +#' +#' @export +#' +rdwp <- function(n, model){ + if (!"dwpm" %in% class(model)) stop("model not of class dwpm") + if ("data" %in% attr(model, "type")){ + attr(model, "type") <- NULL + attr(model, "class") <- NULL + if (!is.list(model)){ + if (NCOL(model) == 1){ + output <- model + } else if (ncol(model) >= n) { + output <- model[ , 1:n] + } else { + stop("n > number of simulated DWPs") + } + } else { + if (NCOL(model[[1]]) == 1){ + output <- model + } else if (ncol(model[[1]]) >= n) { + output <- lapply(model, "[", 1:nrow(model[[1]]), 1:n) + } else { + stop("n > number of simulated DWPs") + } + } + } + class(output) <- "rdwp" + return(output) +} + diff --git a/R/mortality_functions.R b/R/mortality_functions.R index b1f5eb0178b1834f5874d85b9c4dda2d3f3c7d3d..f3af30331a9c76e3ea00514aff63090e0955534d 100644 --- a/R/mortality_functions.R +++ b/R/mortality_functions.R @@ -12,7 +12,8 @@ #' @param data_DWP Survey unit (rows) by size (columns) density weighted #' proportion table #' -#' @param frac fraction of facility (by units or by area) surveyed +#' @param frac fraction carcasses on ground that was surveyed but not accounted +#' for in DWP #' #' @param COdate Column name for the date found data #' @@ -22,6 +23,8 @@ #' @param model_CP Carcass Persistence model (or list of models if there are #' multiple size classes) #' +#' @param model_DWP fitted dwp model (optional) +#' #' @param unitCol Column name for the unit indicator (optional) #' #' @param SSdate Column name for the date searched data @@ -30,6 +33,8 @@ #' are recorded. Optional. If none provided, it is assumed there is no #' distinctions among size classes. #' +#' @param IDcol column with unique carcass (CO) identifier +#' #' @param DWPCol Column name for the DWP values in the DWP table when no #' size class is used and there is more than one column in \code{data_DWP} #' that could be interpreted as DWP. @@ -70,9 +75,9 @@ #' #' @export #' -estM <- function(data_CO, data_SS, data_DWP, frac = 1, - COdate = "DateFound", model_SE, model_CP, - unitCol = NULL, SSdate = NULL, sizeCol = NULL, +estM <- function(data_CO, data_SS, data_DWP = NULL, frac = 1, + COdate = "DateFound", model_SE, model_CP, model_DWP = NULL, + unitCol = NULL, SSdate = NULL, sizeCol = NULL, IDcol = NULL, DWPCol = NULL, seed_SE = NULL, seed_CP = NULL, seed_g = NULL, seed_M = NULL, nsim = 1000, max_intervals = 8){ @@ -80,9 +85,10 @@ estM <- function(data_CO, data_SS, data_DWP, frac = 1, data_CO[i] <- lapply(data_CO[i], as.character) i <- sapply(data_SS, is.factor) data_SS[i] <- lapply(data_SS[i], as.character) - i <- sapply(data_DWP, is.factor) - data_DWP[i] <- lapply(data_DWP[i], as.character) - + if (!is.null(data_DWP) && "data.frame" %in% class(data_DWP)){ + i <- sapply(data_DWP, is.factor) + data_DWP[i] <- lapply(data_DWP[i], as.character) + } if (!(COdate %in% colnames(data_CO))){ stop("COdate not found in data_CO") } @@ -109,15 +115,26 @@ estM <- function(data_CO, data_SS, data_DWP, frac = 1, } } # error-checking for match b/t DWP and CO data is done in DWPbyCarcass - DWP <- DWPbyCarcass(data_DWP = data_DWP, data_CO = data_CO, - sizeCol = sizeCol, unitCol = unitCol, DWPCol = DWPCol) + if (!is.null(data_DWP) && !is.null(model_DWP)) + stop("provide either data_DWP or model_DWP, not both") + if (is.null(data_DWP) && is.null(model_DWP)){ + model_DWP <- dwpm(data_DWP = NULL) + } + if (!is.null(data_DWP)){ + model_DWP <- dwpm(data_DWP = data_DWP, type = "data", unitCol = unitCol, + dwpCols = DWPCol) + } + if (!"dwpm" %in% class(model_DWP)) stop("fitted DWP model required") +# DWP <- DWPbyCarcass(data_DWP = data_DWP, data_CO = data_CO, +# sizeCol = sizeCol, unitCol = unitCol, DWPCol = DWPCol) +# est <- estg(data_CO = data_CO, COdate = COdate, data_SS = data_SS, SSdate = SSdate, - model_SE = model_SE, model_CP = model_CP, - unitCol = unitCol, sizeCol = sizeCol, + model_SE = model_SE, model_CP = model_CP, model_DWP = model_DWP, + unitCol = unitCol, sizeCol = sizeCol, IDcol = IDcol, nsim = nsim, max_intervals = max_intervals, seed_SE = seed_SE, seed_CP = seed_CP, seed_g = seed_g) - gDf <- est$ghat * DWP * frac + gDf <- est$ghat * est$DWP * frac set.seed(seed_M) c_out <- which(rowSums(gDf) == 0) if (length(c_out) == 0){ @@ -129,7 +146,8 @@ estM <- function(data_CO, data_SS, data_DWP, frac = 1, n <- length(gDf) Mhat[-c_out,] <- ((cbinom::rcbinom(n, 1/gDf, gDf)) - (Ecbinom(gDf) - 1))/gDf } - out <- list(Mhat = Mhat, Aj = est$Aj, ghat = est$ghat, DWP = DWP, + row.names(Mhat) <- row.names(est$ghat) + out <- list(Mhat = Mhat, Aj = est$Aj, ghat = est$ghat, DWP = est$DWP, Xtot = nrow(data_CO) - length(c_out)) class(out) <- c("estM", "list") return(out) @@ -139,7 +157,7 @@ estM <- function(data_CO, data_SS, data_DWP, frac = 1, #' #' @description Expand the density weighted proportion table to a value for #' each carcass (across multiple classes if desired) based on the unit where -#' they were found +#' they were found. (Deprecated. See CO_DWP.) #' #' @param data_DWP Survey unit (rows) by size (columns) density weighted #' proportion table @@ -206,7 +224,7 @@ DWPbyCarcass <- function(data_DWP, data_CO, unitCol = NULL, if (!all(unique(data_CO[,sizeCol]) %in% colnames(data_DWP))){ stop("not all sizes in data_CO are represented in data_DWP.") } - # size classes and units have been error-checked, and assigning DWP to + # size classes and units have been error-eschecked, and assigning DWP to # carcasses is a simple extraction of DWP from the appropriate row and # column for each carcass in CO. # unit in CO defines the desired row in DWP: diff --git a/R/splits_figure_functions.R b/R/splits_figure_functions.R index d69ceda3fddc58003605668bf45f3c375faa7812..923a4d37f51e83c15f9480f8375fabcc2053ab5e 100644 --- a/R/splits_figure_functions.R +++ b/R/splits_figure_functions.R @@ -24,11 +24,15 @@ #' include either a \code{split_SS} or \code{split_time} variable, the #' \code{rate} arg is ignored. #' +#' @param commonScale boolean to indicate whether to plot separate splits panels +#' with a common scale on their y-axes (or have y-axes scaled to fit each graph +#' separately) +#' #' @param ... additional arguments to be passed down #' #' @export #' -plot.splitSummary <- function(x, rate = FALSE, ...){ +plot.splitSummary <- function(x, rate = FALSE, commonScale = FALSE, ...){ splits <- x nvar <- length(attr(splits, "vars")) vartype <- attr(splits, "type") @@ -54,6 +58,12 @@ plot.splitSummary <- function(x, rate = FALSE, ...){ nlevel_v <- length(splits) par(mfrow = c(nlevel_v, 1)) cex.axis <- 1*(nlevel_v == 1) + (nlevel_v == 2)/0.83 + (nlevel_v > 2)/0.66 + if (!rate & commonScale & nvar == 2){ + ylim <- c(0, 0) + for (vi in 1:nlevel_v){ + ylim <- range(ylim, splits[[vi]][ , -1]) + } + } for (vi in 1:nlevel_v){ if ((vartype[1] %in% c("time", "SS")) & rate) { hwid <- deltaT/2 @@ -62,7 +72,7 @@ plot.splitSummary <- function(x, rate = FALSE, ...){ } else { hwid <- rep(0.15, nlevel_h) # half-width of boxes xlim <- c(1, nlevel_h) + 0.5 * c(-1, 1) - ylim <- range(splits[[vi]][ , -1]) + if (!commonScale) ylim <- range(splits[[vi]][ , -1]) } if (vi == 1 && !is.null(try(plot.new(), silent = TRUE))){ par(mfrow = c(1,1)) @@ -168,7 +178,7 @@ plot.splitFull <- function(x, rate = FALSE, CL = 0.90, ...){ simpleMplot(x, ..., CL = CL) } else{ splitSum <- summary(x, CL) - if(!is.null(plot(splitSum, rate))){ + if(!is.null(plot(splitSum, rate, CL = CL))){ stop("Second split too fine for plotting. Consider transposing.") } } diff --git a/REVISIONS.txt b/REVISIONS.txt index 76a8dde5b07543cb37086bbdc6fda84bc47cbe18..d08005c04c5b2ac68843dddded0a0cc31406a852 100644 --- a/REVISIONS.txt +++ b/REVISIONS.txt @@ -1,4 +1,21 @@ -Revision log +Revision log +2019.07.17 +v1.3.0 + +* more informative data downloads with more useful default file names (GUI) + +* option to plot multiple 'splits' graphics panels on common y-axis scale (GUI) + +* unique carcass ID used as row names in the Mhat element of estM objects. +This will help facilitate the performing of complicated, custom mortality splits +from the command-line. + +* new placeholder functions for accommodating the incorporation of a DWP +module sometime in the not-to-distant future. Currently, the only function +available is a null model that simply reads DWP data that was generated outside +GenEst. The models (including the null model) can accomodate uncertainties +in the estimation of DWP. + 2019.04.12 v1.2.4 diff --git a/code.json b/code.json index 8826241a9bcf309e6f66f25915e35abe69565b2b..6cbfab81ad8f15240d04a7fae897dba6325af2c1 100644 --- a/code.json +++ b/code.json @@ -3,7 +3,7 @@ "Name": "GenEst", "organization": "U.S. Geological Survey", "description": "R package for estimating bird and bat fatalities at wind and solar power facilities", - "version": "1.2.4", + "version": "1.3.0", "status": "Release Candidate", "permissions": { @@ -44,7 +44,7 @@ }, "date": { - "metadataLastUpdated": "2019-04-12" + "metadataLastUpdated": "2019-07-17" } } } } diff --git a/man/CO_DWP.Rd b/man/CO_DWP.Rd new file mode 100644 index 0000000000000000000000000000000000000000..2f60b072d34ca9a00962d0f7b5b4a2c2c6df681e --- /dev/null +++ b/man/CO_DWP.Rd @@ -0,0 +1,25 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/detection_probability_functions.R +\name{CO_DWP} +\alias{CO_DWP} +\title{Associate CO carcasses with appropriate DWP values (by unit and carcass class)} +\usage{ +CO_DWP(dwpsim, data_CO, unitCol, sizeCol = NULL) +} +\arguments{ +\item{dwpsim}{\code{rdwp} object} + +\item{data_CO}{data frame with results from carcass surveys} + +\item{unitCol}{name of the unit column in data_CO (required)} + +\item{sizeCol}{name of the size column in data_CO (optional).} +} +\value{ +numeric DWP array +} +\description{ +Calculate the conditional probability of observing a carcass + at search oi as a function arrival interval (assuming carcass is not + removed by scavengers before the time of the final search) +} diff --git a/man/DWPbyCarcass.Rd b/man/DWPbyCarcass.Rd index 3d1d9694c45733532e1715381da7b6a9813c3fe5..62ddfc18c169b4b0dc3a69846dc45622894ab620 100644 --- a/man/DWPbyCarcass.Rd +++ b/man/DWPbyCarcass.Rd @@ -36,7 +36,7 @@ DWP value for each carcass \description{ Expand the density weighted proportion table to a value for each carcass (across multiple classes if desired) based on the unit where - they were found + they were found. (Deprecated. See CO_DWP.) } \examples{ data(mock) diff --git a/man/cpmCPCellPlot.Rd b/man/cpmCPCellPlot.Rd index 07ff17132a4f38cc9fc7b362c51a9186969649d2..bb879020252defc99b5283fc84c6cac30482c0db 100644 --- a/man/cpmCPCellPlot.Rd +++ b/man/cpmCPCellPlot.Rd @@ -18,6 +18,6 @@ cpmCPCellPlot(model, specificCell, col, axis_y = TRUE, axis_x = TRUE) \item{axis_x}{logical of whether or not to plot the x axis} } \description{ -Produce the figure panel for a specific cell (factor +Produce the figure panel for a specific cell (factor level combination) including the specific fitted decay curves. } diff --git a/man/downloadCPmod.Rd b/man/downloadCPmod.Rd new file mode 100644 index 0000000000000000000000000000000000000000..c07bd030caf9c89570f923250093ab8bd335ef86 --- /dev/null +++ b/man/downloadCPmod.Rd @@ -0,0 +1,19 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/app_download_functions.R +\name{downloadCPmod} +\alias{downloadCPmod} +\title{Download summary of CP model fitting} +\usage{ +downloadCPmod(rv, input) +} +\arguments{ +\item{rv}{the reactive values list,} + +\item{input}{list of shiny input parameters} +} +\value{ +a download handler function +} +\description{ +Handle the CP model downloading +} diff --git a/man/downloadMres.Rd b/man/downloadMres.Rd new file mode 100644 index 0000000000000000000000000000000000000000..becc042f0d36d7546459cfc281d3d21cfa743547 --- /dev/null +++ b/man/downloadMres.Rd @@ -0,0 +1,19 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/app_download_functions.R +\name{downloadMres} +\alias{downloadMres} +\title{Download M results (including SE and CP modeling)} +\usage{ +downloadMres(rv, input) +} +\arguments{ +\item{rv}{the reactive values list} + +\item{input}{shiny input data} +} +\value{ +a download handler function +} +\description{ +Handle the downloading of results +} diff --git a/man/downloadSEmod.Rd b/man/downloadSEmod.Rd new file mode 100644 index 0000000000000000000000000000000000000000..8bf965b2cc966d7cab379d0f79a18a0a963cb1d1 --- /dev/null +++ b/man/downloadSEmod.Rd @@ -0,0 +1,19 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/app_download_functions.R +\name{downloadSEmod} +\alias{downloadSEmod} +\title{Download summary of SE model fitting} +\usage{ +downloadSEmod(rv, input) +} +\arguments{ +\item{rv}{the reactive values list} + +\item{input}{the shiny input data} +} +\value{ +a download handler function +} +\description{ +Handle the SE model downloading +} diff --git a/man/dwpm.Rd b/man/dwpm.Rd new file mode 100644 index 0000000000000000000000000000000000000000..bb29d5aef33373c98e4f41fb9908f9c4f60c2546 --- /dev/null +++ b/man/dwpm.Rd @@ -0,0 +1,62 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/dwp_functions.R +\name{dwpm} +\alias{dwpm} +\title{Fit density-weighted proportion (DWP) models.} +\usage{ +dwpm(data_DWP, type = "data", unitCol = NULL, dwpCols = NULL) +} +\arguments{ +\item{data_DWP}{data frame with structure depending on model +type. In general, \code{data_DWP} would be a data frame if a model is to be +fit or if point estimates only are provided as pre-simulated DWP data, and, +if pre-simulated data with variation are provided, then a 2-d array (if one +carcass class) or a list of 2-d arrays (if more than one carcass class). See +"Details" for details.} + +\item{type}{model type may be \code{rings}, \code{glm}, \code{TWL}, or +\code{data}. Currently, only the \code{data} type is supported.} + +\item{unitCol}{name of the column with the units, which must be non-numeric} + +\item{dwpCols}{name(s) of the columns with the DWP data} +} +\value{ +an object of an object of class \code{dwpm}, which is a list with + model \code{type} (currently only \code{type = data} is supported) and + \code{model}, which gives the simulated DWP values as an array (if there's + only a single carcass class) or a list of arrays (if there are more than one + carcass classes). +} +\description{ +Carcass density is modeled as a function of distance from + turbine. Format and usage parallel that of common \code{R} functions + \code{lm}, \code{glm}, and \code{gam} and the GenEst functions \code{pkm} + and \code{cpm}. +} +\details{ +The fraction of carcasses falling in the area searched at a turbine + may be a function of carcass class (e.g., large or small) and/or direction + from the turbine. Data may be provided for fitting a distance model(s) or, + alternatively, simulated turbine-wise DWP data from custom-fitted models may + be provided. If pre-fit, pre-simulated data are used, then \code{glm} returns + a \code{dwpm} object with \code{type = data}. + + To fit a model, \code{data_DWP} should be a data frame with a row for each carcass + and columns giving (at a minimum) unique carcass IDs, turbine ID, distance + from turbine, and fraction of area searched at the given distance at the + given turbine. Optional columns may include size class, covariates that may + influence detection probability (e.g., visibility class), and direction. + If covariates are to be included in the model, then the fraction of area + column would give the fraction of the area in the given covariate level at + that distance. Alternatively, prefab data may be provided in a dataframe, + with structure depending on data type. The simplest case would be that + point estimates only are provided. In that case, if there are no distinctions + among carcass classes (e.g., size), then \code{data_DWP} should be a dataframe + with one column giving the unit (e.g., turbine) and one column with the DWP + at each unit; if distinctions are made among sizes, then \code{data_DWP} would + be a data frame with a unit column and a DWP column for each size class. If + the DWP estimates incorporate uncertainties, then \code{data_DWP} should be + an array with \code{n_unit * nsim} rows and with colunms for units and DWPs for + each carcass class. +} diff --git a/man/estM.Rd b/man/estM.Rd index 513be8aa727a1110afe89dadced393b105706697..ad75538df3619a3c109ea9c709b8d2656a57d665 100644 --- a/man/estM.Rd +++ b/man/estM.Rd @@ -4,8 +4,9 @@ \alias{estM} \title{Estimate mortality} \usage{ -estM(data_CO, data_SS, data_DWP, frac = 1, COdate = "DateFound", - model_SE, model_CP, unitCol = NULL, SSdate = NULL, sizeCol = NULL, +estM(data_CO, data_SS, data_DWP = NULL, frac = 1, + COdate = "DateFound", model_SE, model_CP, model_DWP = NULL, + unitCol = NULL, SSdate = NULL, sizeCol = NULL, IDcol = NULL, DWPCol = NULL, seed_SE = NULL, seed_CP = NULL, seed_g = NULL, seed_M = NULL, nsim = 1000, max_intervals = 8) } @@ -17,7 +18,8 @@ estM(data_CO, data_SS, data_DWP, frac = 1, COdate = "DateFound", \item{data_DWP}{Survey unit (rows) by size (columns) density weighted proportion table} -\item{frac}{fraction of facility (by units or by area) surveyed} +\item{frac}{fraction carcasses on ground that was surveyed but not accounted +for in DWP} \item{COdate}{Column name for the date found data} @@ -27,6 +29,8 @@ multiple size classes)} \item{model_CP}{Carcass Persistence model (or list of models if there are multiple size classes)} +\item{model_DWP}{fitted dwp model (optional)} + \item{unitCol}{Column name for the unit indicator (optional)} \item{SSdate}{Column name for the date searched data} @@ -35,6 +39,8 @@ multiple size classes)} are recorded. Optional. If none provided, it is assumed there is no distinctions among size classes.} +\item{IDcol}{column with unique carcass (CO) identifier} + \item{DWPCol}{Column name for the DWP values in the DWP table when no size class is used and there is more than one column in \code{data_DWP} that could be interpreted as DWP.} @@ -53,7 +59,8 @@ that could be interpreted as DWP.} for each carcass} } \value{ -list of Mhat, Aj, ghat +list of Mhat, Aj, ghat, DWP (by carcass), and Xtot = total number of + carcasses observe } \description{ Given given fitted Searcher Efficiency and Carcass diff --git a/man/estg.Rd b/man/estg.Rd index e389aeeb33d7666cca3d1bf567306ebff23569aa..87614d13e0ab9d822b6171c3743818acabbe81cd 100644 --- a/man/estg.Rd +++ b/man/estg.Rd @@ -5,8 +5,9 @@ \title{Estimate all carcass-level detection rates and arrival intervals} \usage{ estg(data_CO, COdate, data_SS, SSdate = NULL, model_SE, model_CP, - sizeCol = NULL, unitCol = NULL, nsim = 1000, max_intervals = 8, - seed_SE = NULL, seed_CP = NULL, seed_g = NULL) + model_DWP = NULL, sizeCol = NULL, unitCol = NULL, IDcol = NULL, + nsim = 1000, max_intervals = 8, seed_SE = NULL, seed_CP = NULL, + seed_g = NULL) } \arguments{ \item{data_CO}{Carcass Observation data} @@ -25,6 +26,9 @@ multiple size classes)} \item{model_CP}{Carcass Persistence model (or list of models if there are multiple size classes)} +\item{model_DWP}{Density weighted proportion model (or list of models if +there are multiple size classes)} + \item{sizeCol}{Name of column in \code{data_CO} where the size classes are recorded. Optional. If not provided, no distinctions are made among sizes. \code{sizeCol} not only identifies what the name of the size @@ -32,6 +36,8 @@ segregating class} \item{unitCol}{Column name for the unit indicator} +\item{IDcol}{Column name for unique carcass IDs (required)} + \item{nsim}{the number of simulation draws} \item{max_intervals}{maximum number of arrival interval intervals to diff --git a/man/modelInputWidget.Rd b/man/modelInputWidget.Rd index a060cc8a67efe6342d791a60fd1ab11efa2f833f..3bd6362824d481ad6e2a044909c0cd0d2721c15a 100644 --- a/man/modelInputWidget.Rd +++ b/man/modelInputWidget.Rd @@ -9,7 +9,7 @@ modelInputWidget(inType) \arguments{ \item{inType}{Toggle control for the input type of the widget. One of "nsim", "CL", "class", "obsSE", "predsSE", "kFixed", "ltp", "fta", -"predsCP", "dist", "frac", "DWPCol", "COdate", "gSearchInterval", or +"predsCP", "dist", "xID", "frac", "DWPCol", "COdate", "gSearchInterval", or "gSearchMax".} } \value{ diff --git a/man/plot.splitSummary.Rd b/man/plot.splitSummary.Rd index 0397a10cc3e814c1b0e5d2d56718bdb55a7d8354..dba40b18c92fe554e54e0fce3d06e7e5589e16db 100644 --- a/man/plot.splitSummary.Rd +++ b/man/plot.splitSummary.Rd @@ -4,7 +4,7 @@ \alias{plot.splitSummary} \title{Plot summary statistics for splits of mortality estimates} \usage{ -\method{plot}{splitSummary}(x, rate = FALSE, ...) +\method{plot}{splitSummary}(x, rate = FALSE, commonScale = FALSE, ...) } \arguments{ \item{x}{A \code{splitSummary} object (result of \code{\link{calcSplits}}) @@ -17,6 +17,10 @@ fatality rates per unit time (\code{rate = TRUE}). If the splits do not include either a \code{split_SS} or \code{split_time} variable, the \code{rate} arg is ignored.} +\item{commonScale}{boolean to indicate whether to plot separate splits panels +with a common scale on their y-axes (or have y-axes scaled to fit each graph +separately)} + \item{...}{additional arguments to be passed down} } \description{ diff --git a/man/rdwp.Rd b/man/rdwp.Rd new file mode 100644 index 0000000000000000000000000000000000000000..d309642ca3f5d3d967edbc7d074d8698e03fa8f5 --- /dev/null +++ b/man/rdwp.Rd @@ -0,0 +1,26 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/dwp_functions.R +\name{rdwp} +\alias{rdwp} +\title{Simulate parameters from a fitted dwp model} +\usage{ +rdwp(n, model) +} +\arguments{ +\item{n}{the number of simulation draws} + +\item{model}{A \code{\link{dwpm}} object (which is returned from +\code{dwpm()})} +} +\value{ +array of \code{n} simulated \code{dwp} values for each unit. + Dimensions = c(n, number of units). +} +\description{ +Simulate parameters from a \code{\link{dwpm}} model object +} +\details{ +If the model type = \code{data}, then the number of simulated columns + must be either \code{>=n} (in which case the first n colunms are taken as the + simulated DWP) or 1 (in which case, DWP is assumed constant). +} diff --git a/man/update_output.Rd b/man/update_output.Rd index 0f1e2f181b4ea21ac14b545289d7087718df5eb2..b515d006fc5314c7cff473278e5bc0ca9c822b5b 100644 --- a/man/update_output.Rd +++ b/man/update_output.Rd @@ -4,7 +4,7 @@ \alias{update_output} \title{Update the outputs when an event occurs} \usage{ -update_output(eventName, rv, output) +update_output(eventName, rv, output, input) } \arguments{ \item{eventName}{Character name of the event. One of "clear_all", @@ -19,6 +19,8 @@ update_output(eventName, rv, output) \item{rv}{Reactive values list for the GenEst GUI.} \item{output}{\code{output} list for the GenEst GUI.} + +\item{input}{\code{input} lisst for the GenEst GUI} } \value{ Updated \code{output} list. diff --git a/man/widgetMaker.Rd b/man/widgetMaker.Rd index 96f80331e088e1b3e6bd8a5b5ad38a1544cdae79..17bee9855007da010ba5f11858c7a05436afe434 100644 --- a/man/widgetMaker.Rd +++ b/man/widgetMaker.Rd @@ -24,6 +24,6 @@ HTML for the widget. \description{ Basic generalized function for creating an input widget based on the condition of the widget being presented, the name of the widget, - the function used to create it, it's label on the UI, and any additional + the function used to create it, its label on the UI, and any additional arguments. }