Nothing
#' @title GenEst App Messages
#'
#' @description lists of messages used in the app
#'
#' @param msgs message list
#'
#' @param clear logical indicator if clearing should happen.
#'
#' @param modelType "SE", "CP", "g", or "M"
#'
#' @param rv reactive values list
#'
#' @param type "SE", "CP", "M", "split", or "g"
#'
#' @param mods Set Size list of models
#'
#' @param special indicator of a special type of message
#'
#' @param fracNote the note regarding the input
#'
#' @name app_msg_functions
NULL
#' @rdname app_msg_functions
#'
#'
msgList <- function(){
list(ModSE = NULL, ModCP = NULL, ModM = NULL, SS = NULL, Modg = NULL)
}
#' @rdname app_msg_functions
#'
clearNotifications <- function(msgs = msgList(), clear = TRUE){
if(clear){
if (!is.null(msgs$ModSE)){
removeNotification(msgs$ModSE)
}
if (!is.null(msgs$ModCP)){
removeNotification(msgs$ModCP)
}
if (!is.null(msgs$ModM)){
removeNotification(msgs$ModM)
}
if (!is.null(msgs$SS)){
removeNotification(msgs$SS)
}
if (!is.null(msgs$Modg)){
removeNotification(msgs$Modg)
}
}
}
#' @rdname app_msg_functions
#'
msgModRun <- function(msgs, modelType, clear = TRUE){
clearNotifications(msgs, clear)
msg <- NULL
if (modelType == "SE"){
msg <- ("Running Searcher Efficiency Model")
}
if (modelType == "CP"){
msg <- ("Running Carcass Persistence Model")
}
if (modelType == "g"){
msg <- ("Running Detection Probability Model")
}
if (modelType == "M"){
msg <- ("Estimating Mortality")
}
if(!is.null(msg)){
return(showNotification(msg, duration = NULL))
}
}
#' @rdname app_msg_functions
#'
msgModDone <- function(msgs, rv, type = "SE", clear = TRUE){
clearNotifications(msgs, clear)
if (type == "SE"){
if ("error" %in% class(rv$mods_SE)){
return(msgModFail(rv$mods_SE, type = "SE", special = "error"))
} else {
kfix <- which(!is.na(rv$kFixed))
if (length(kfix) > 0 && any(rv$kFixed[kfix] > 1)){
return(msgModFail(rv$mods_SE_og, "SE", "NA_kFixed"))
} else if (length(kfix) > 0 && any(rv$kFixed[kfix] < 0)){
return(msgModFail(rv$mods_SE_og, "SE", "NA_kFixed"))
} else if (all(unlist(pkmSetSizeFail(rv$mods_SE_og)))){
return(msgModFail(rv$mods_SE_og, "SE"))
} else if(any(unlist(lapply(rv$mods_SE_og, pkmSetAllFail)))){
return(msgModFail(rv$mods_SE_og, "SE", "size_k"))
} else {
return(msgModWarning(rv$mods_SE_og, "SE", rv))
}
}
}
if (type == "CP"){
if (all(unlist(cpmSetSizeFail(rv$mods_CP_og)))){
return(msgModFail(rv$mods_CP_og, "CP"))
} else{
return(msgModWarning(rv$mods_CP_og, "CP"))
}
}
if (type == "M"){
if (is.null(rv$M)){
if (!is.null(rv$fracNote)){
return(msgFracNote(rv$fracNote))
} else {
return(msgModFail(mods = rv$M, "M"))
}
} else if ("error" %in% class(rv$M)){
if (!is.null(rv$fracNote)){
return(msgFracNote(rv$fracNote))
} else {
return(msgModFail(mods = rv$M[1], type = "M"))
}
}
}
if (type == "split"){
if (rv$nsplit_CO + rv$nsplit_SS > 2 | rv$nsplit_SS > 1){
return(msgSplitFail("setup"))
}
if (is.null(rv$Msplit)){
return(msgSplitFail("run"))
}
}
if (type == "g"){
if ((is.null(rv$gGeneric))){
if (is.null(rv$gGeneric[[1]])){
return(msgModFail(rv$gGeneric, "g"))
}
}
}
NULL
}
#' @rdname app_msg_functions
msgModPartialFail <- function(mods, type = "SE"){
anyFail <- FALSE
if (type == "SE"){
if (any(unlist(pkmSetSizeFail(mods)))){
anyFail <- TRUE
}
}
if (type == "CP"){
if (any(unlist(cpmSetSizeFail(mods)))){
anyFail <- TRUE
}
}
if (!anyFail){
return(NULL)
}
nsizeclass <- length(mods)
uniquemsgs <- NULL
for (sci in names(mods)){
newmsgs <- NULL
if (type == "SE"){
failedmods <- which(pkmSetFail(mods[[sci]]))
}
if (type == "CP"){
failedmods <- which(cpmSetFail(mods[[sci]]))
}
nfailedmods <- length(failedmods)
if (nfailedmods > 0){
for(fmodi in 1:nfailedmods){
newmsg <- mods[[sci]][[names(failedmods)[fmodi]]]
if (length(newmsg) == 1){
newmsg <- gsub("Failed model fit: ", "", newmsg)
} else{
newmsg <- "Failed fit for k."
}
newmsgs <- unique(c(newmsgs, newmsg))
}
}
uniquemsgs <- unique(c(uniquemsgs, newmsgs))
}
paste0(
"Some models were not successfully fit. Failed models were removed. ",
paste(uniquemsgs, collapse = " ")
)
}
#' @rdname app_msg_functions
#'
msgSampleSize <- function(mods){
cellCounts <- countCarcs(mods)
minCellCount <- min(na.omit(cellCounts))
if (minCellCount < 10){
if (length(cellCounts) == 1){
return(paste0("Caution: n = ", cellCounts, " trial carcasses may be too ",
"few for reliably estimating searcher efficiency parameters."))
}
return(paste0("Small (< 10) sample sizes in some cells. ",
"Consider simplifying the model; parameter estimates may be unstable."))
}
NULL
}
#' @rdname app_msg_functions
#'
msgModWarning <- function(mods, type = "SE", rv = NULL){
msg <- paste(msgModPartialFail(mods, type), msgSampleSize(mods), sep = " ")
if (type == "SE"){
msg <- paste(msg, msgModSENobs(rv), sep = " ")
}
if (length(msg) > 0){
return(showNotification(msg, type = "warning", duration = NULL))
}
NULL
}
#' @rdname app_msg_functions
#'
msgModSENobs <- function(rv){
if (length(rv$obsCols_SE) == 1){
if(length(rv$formula_k) > 0 & any(is.na(rv$kFixed))){
return("Only one observation column, k not estimated.")
}
}
NULL
}
#' @rdname app_msg_functions
#'
msgModFail <- function(mods, type = "SE", special = NULL){
if (type %in% c("SE", "CP")){
if (is.null(special)){
msg <- paste(
"No models were successfully fit.",
gsub("Failed model fit: ", "", unique(unlist(mods))),
sep = " "
)
} else if (special == "error") {
msg <- mods
} else if (special == "size_k"){
msg <- "Some carcass classes had no successful models. Consider a fixed k."
} else if (special == "NA_kFixed"){
msg <- "invalid value entered for fixed k"
}
}
if (type == "g"){
msg <- "Cannot estimate detection probability"
}
if (type == "M"){
msg <- mods
}
if(!is.null(msg)){
return(showNotification(msg, type = "error", duration = NULL))
}
}
#' @rdname app_msg_functions
#'
msgSSavgFail <- function(msgs, rv, clear = TRUE){
if (clear){
clearNotifications(msgs)
}
if (is.na(rv$SStemp[1])){
msg <- "Search Schedule can't be averaged using date searched column"
return(showNotification(msg, type = "warning", duration = NULL))
}
NULL
}
#' @rdname app_msg_functions
#'
msgSSinputFail <- function(msgs, rv, clear = TRUE){
if (clear){
clearNotifications(msgs)
}
if (is.na(rv$SStemp[1])){
msg <- "Search Schedule can't be created using inputs"
return(showNotification(msg, type = "warning", duration = NULL))
}
NULL
}
#' @rdname app_msg_functions
#'
msgSplitFail <- function(type = NULL){
if (is.null(type)){
return(NULL)
}
if (type == "setup"){
msg <- paste0(
"Improper splits setup. Maximum two splits, only one of which ",
"can be associated with the search schedule."
)
}
if (type == "run"){
msg <- "Splits calculation failed. Check split selections."
}
return(showNotification(msg, type = "error", duration = NULL))
}
#' @rdname app_msg_functions
#'
msgFracNote <- function(fracNote){
return(showNotification(fracNote, type = "warning", duration = NULL))
}
Any scripts or data that you put into this service are public.
Add the following code to your website.
For more information on customizing the embed code, read Embedding Snippets.