R/fct_helpers.R
In peernisse/riverMenu: Create Multi-Day Group Menu Plans for Wilderness River Trips
Defines functions
mkLocalLookup
filterPickMealType
pickMealType
mkViewMenuIngredients
gsGetIDs
read_gs
# Define database Connection info and store database location string in global environment
dbURL <<- 'https://docs.google.com/spreadsheets/d/1qbWU0Ix6VrUumYObYyddZ1NvCTEjVk18VeWxbvrw5iY/edit?usp=sharing'
#' @title Read Google Sheets
#' @name read_gs
#'
#' @description reads googlesheets data on app startup
#'
#' @return database menu tables
#'
#' @noRd
read_gs<-function(db = dbURL){
'<<-' <- XREF_INGREDIENT <- LU_MEAL_TYPE <- LU_MEAL <- LU_INGREDIENTS <- NULL
url <- db
XREF_INGREDIENT <<- googlesheets4::read_sheet(url, sheet = "XREF_INGREDIENT")
LU_MEAL_TYPE <<- googlesheets4::read_sheet(url, sheet = "LU_MEAL_TYPE")
LU_MEAL <<- googlesheets4::read_sheet(url, sheet = 'LU_MEAL')
LU_INGREDIENTS <<- googlesheets4::read_sheet(url, sheet = "LU_INGREDIENTS")
}
#'Function to get new meal and ingredient IDs prior to appending new data
#' @description Gets max ingredient and meal IDs + 1 to use for adding new items to datatbase
#'
#' @param cache The location of the gs4_auth secret to authenticate
#'
#' @param email The developer email to use for the google sheets account auth
#'
#' @return Returns a list of 2 new IDs, one for ingredient and one for meal
#'
#' @noRd
gsGetIDs <- function(db = dbURL){
'<<-' <- XREF_INGREDIENT <- LU_MEAL_TYPE <- LU_MEAL <- LU_INGREDIENTS <- NULL #This is here to solve errors in package checking
url <- db
nmID <- googlesheets4::read_sheet(url, sheet = "LU_MEAL")[['MEAL_ID']] %>% max() + 1
niID <- googlesheets4::read_sheet(url, sheet = "LU_INGREDIENTS")[['INGREDIENT_ID']] %>% max() + 1
out<- list(nmID = nmID, niID = niID)
return(out)
}#end gsGetIDs
#' make view menu ingredients dataframe
#' @description Creates and updates all meals dataframe for appending new meals
#'
#' @param data The reactive values list common to all modules.
#'
#' @return dataframe of all existing meals in the database.
#'
#' @noRd
mkViewMenuIngredients <- function(data){
LOCAL <- data
LOCAL$viewMenuIngredients <- LOCAL$xrefIng %>%
inner_join(LOCAL$lm) %>%
inner_join(LOCAL$li, by = c("INGREDIENT_ID", "INGREDIENT"))
if ('SERVING_SIZE_FACTOR.x' %in% names(LOCAL$viewMenuIngredients)){
LOCAL$viewMenuIngredients <- LOCAL$viewMenuIngredients %>%
mutate(SERVING_SIZE_FACTOR = case_when(
!is.na(SERVING_SIZE_FACTOR.x) ~ SERVING_SIZE_FACTOR.x,
TRUE ~ SERVING_SIZE_FACTOR.y
)#end case_when
)#end mutate
}#end if
LOCAL$viewMenuIngredients <- LOCAL$viewMenuIngredients %>%
select(MEAL_NAME,MEAL_TYPE,MEAL_DESCRIPTION,INGREDIENT,INGREDIENT_DESCRIPTION,SERVING_SIZE_DESCRIPTION,
SERVING_SIZE_FACTOR,MEAL_ID,INGREDIENT_ID) %>%
arrange(MEAL_NAME,INGREDIENT)
return(LOCAL$viewMenuIngredients)
}
#'
#' Pick meal type picker
#' @description Reused function for picker input pick meal type. Designed to be used inside renderUI in the server function
#'
#' @param data The reactive values list common to all modules
#'
#' @param control The id for the picker input
#'
#' @param label The label for the picker input
#'
#' @param selected The selected value for the picker input
#'
#' @param session,input,output Shiny session objects shared between all modules.
#'
#' @return UI picker input for meal type
#'
#' @noRd
pickMealType <- function(session,input,output,data,control = 'choosemealtype',label,selected = '--Select Meal Type--'){
LOCAL <- data
output$lumtype2<-renderUI({
ns<-session$ns
pickerInput(
ns(control),label = label,
selected = selected,
choices = c('--Select Meal Type--',isolate(LOCAL$lmt %>% pull(MEAL_TYPE)))
)
})#End lu meal type
}#end pickMealType
#'
#'
#' filterPickMealType
#'
#' @description Logic for cascading filterable picker lists
#'
#' @param data The reactive values list common to all modules
#'
#' @param session,input,output Shiny session objects shared between all modules.
#'
#' @return Updated picker choices.
#'
#' @noRd
filterPickMealType <- function(session,input,output,data){
LOCAL <- data
mls<-LOCAL$lm %>%
filter(MEAL_TYPE %in% input$choosemealtype) %>%
pull(MEAL_NAME) %>%
as.character() %>%
sort()
prompt<-ifelse(
input$choosemealtype == '--Select Meal Type--',
'--Select Meal Type First--',
paste0('--Select ',input$choosemealtype,'--')
)#End ifelse
updatePickerInput(session,'choosemeal',label='Meal Name',
selected = prompt,
choices = c(prompt,mls))
}#end filterPickMealType
#'
#' #Make first LOCAL$lookup
#'
#' @description Instantiates the main reactive values dataframe that holds the
#' menu being built
#'
#' @param data The reactive values list common to all modules
#'
#' @param newLine Receives a one row dataframe of user input to be built out
#' into the full menu entry
#'
#' @param session,input,output Shiny session objects shared between all modules.
#'
#' @return The main reactive value dataframe of the menu building session.
#'
#' @noRd
mkLocalLookup <- function(session,input,output,data, newLine = NULL){
LOCAL <- data
#Create main menu dataframe for the session
llOut<-newLine %>% #this gets the river day in case meals are repeated on the trip
mutate(NO_PEOPLE = as.numeric(NO_PEOPLE)) %>%
left_join(LOCAL$viewMenuIngredients, by = c('MEAL_NAME' = 'MEAL_NAME','MEAL_TYPE' = 'MEAL_TYPE')) %>%
as.data.frame(.) %>%
mutate(QUANTITY = round_any(SERVING_SIZE_FACTOR*NO_PEOPLE,1,ceiling), REVISED = '') %>%
select(RIVER_DAY,MEAL_TYPE,MEAL_NAME,MEAL_DESCRIPTION,INGREDIENT,QUANTITY,INGREDIENT_DESCRIPTION,SERVING_SIZE_DESCRIPTION,
NO_PEOPLE,SERVING_SIZE_FACTOR,REVISED,MEAL_ID,INGREDIENT_ID) %>%
bind_rows(LOCAL$lookup) %>%
as.data.frame(.) %>%
mutate(#This sets factors so the table filter dropdowns appears
RIVER_DAY = factor(RIVER_DAY, levels = seq(min(RIVER_DAY),max(RIVER_DAY),1)),
MEAL_NAME = factor(MEAL_NAME, levels = unique(MEAL_NAME)),
INGREDIENT = factor(INGREDIENT, levels = unique(INGREDIENT)),
MEAL_TYPE = factor(MEAL_TYPE,levels = LOCAL$lmt$MEAL_TYPE)
) %>% #end mutate
arrange(RIVER_DAY,MEAL_TYPE)
return(llOut)
}#end function
#'@description A wrapper of datatable() to create a datatable to be output with renderDT
#'
#'@param df The dataframe to be in the datatable
#'
#'@param edit Logical Whether the datatable will be editable
#'
#'@param filter The location of the filter in the rendered table. Default to 'none'
#'
#'@param dom The datatable options argument for which DOM objects to show in the rendered table
#'
#'@param scrollY The height of the output table in pixels whereby a scroll bar is grown.
#'
#'@param session Shiny session object shared between all modules.
#'
#'@return The datatable configured to be output via renderDT.
#'
#' @noRd
dtStyle1 <- function(session,df,edit = TRUE, filter = 'none', dom = 't',scrollY = '400px'){
datatable(
data = df,
rownames = FALSE,
style = "bootstrap",
filter = filter,
editable = edit,
options = list(fixedHeader = TRUE, pageLength = 1000, scrollX = TRUE, scrollY = scrollY, dom = dom)
)#end datatable
}#end function dtStyle1
#'
#' Add meal to the menu. Takes user input and combines with stored ingredients to create the main working
#' dataframe for the tool.
#'
#' @description The button to commit a selected meal to the main menu reactive value dataframe
#'
#' @param data The reactive values list common to all modules
#'
#' @param session,input,output Shiny session objects shared between all modules.
#'
#' @return A meal selection and associated ingredient are modified by number of people
#' and added to the menu
#'
#' @noRd
addMeal<-function(session,input,output, data){
LOCAL <- data
if(nrow(LOCAL$menu)>0){
mealCheck<-LOCAL$menu %>%
mutate(uniqueDay_MT_MN = paste(RIVER_DAY,MEAL_TYPE,MEAL_NAME)) %>%
select(uniqueDay_MT_MN) %>%
unique(.) %>%
as.data.frame(.)
} else {
mealCheck<-data.frame(uniqueDay_MT_MN = '')
}
#Check for same meal same day
#Require river day input
if(input$riverday == "" | is.na(as.numeric(input$riverday))==TRUE){
showModal(modalDialog(
title="Warning!",
"Select a river day"
))
return(NULL)
} else
if(input$nopeople == "" | is.na(as.numeric(input$nopeople))==TRUE){
showModal(modalDialog(
title="Warning!",
"Select number of people"
))
return(NULL)
} else
if(paste(input$riverday,input$choosemealtype,input$choosemeal) %in% mealCheck$uniqueDay_MT_MN){
showModal(modalDialog(
title = "Day and Meal Conflict",
"This meal exists on this day already",
easyClose = TRUE
))
return(NULL)
} else {
#Create new meal DF from inputs
LOCAL$newLine <- data.frame(
RIVER_DAY = input$riverday,
MEAL_TYPE = input$choosemealtype,
MEAL_NAME = input$choosemeal,
NO_PEOPLE = as.numeric(input$nopeople),
stringsAsFactors = FALSE
)
#Create main menu tables for the session----------------------
#Create local view menu ingredients with everything in it
LOCAL$viewMenuIngredients <- mkViewMenuIngredients(data = LOCAL)
LOCAL$lookup <- mkLocalLookup(session,input,output,data = LOCAL, newLine = LOCAL$newLine)
#Menu Overview
LOCAL$menu <- LOCAL$lookup %>%
select(RIVER_DAY,MEAL_TYPE,MEAL_NAME,NO_PEOPLE,MEAL_ID) %>%
unique(.)
#select current meal
#Create unique id for day and meal ID
LOCAL$menu <- LOCAL$menu %>% mutate(UNIQUE_ID = paste0(RIVER_DAY,'_',MEAL_ID))
#Get the row numbers where this unique id is
LOCAL$menuSelectedRows <- LOCAL$menu[which(LOCAL$menu$MEAL_NAME == input$choosemeal),] %>% pull(UNIQUE_ID) %>% tail(.,1)
#LOCAL$menuFilter <- LOCAL$menu %>% .[LOCAL$menuSelectedRows,]
#Reset meal type and meal name pickers
updatePickerInput(session,'choosemealtype',selected = '--Select Meal Type--',
choices = c('--Select Meal Type--',LOCAL$lmt$MEAL_TYPE))
#kill LOCAL$newLine
LOCAL$newLine <- data.frame()
}#end if else
}#end addMeal button function
#'
#' Edit meal button. User can edit one meal at a time, if one meal is selected this button begins edit mode.
#'
#' @description Begins meal edit mode. Generates temporary dataframe of one meal
#' to be edited then put back in the main menu.
#'
#' @param data The reactive values list common to all modules, named 'LOCAL'. Default value is 'LOCAL'
#'
#' @param session,input,output Shiny session objects shared between all modules.
#'
#' @return A temporary meal dataframe containing one meal and ingredients to be edited.
#'
#' @noRd
editMeal <- function(session,input,output, data = LOCAL){
LOCAL <- data
if (is.null(input$menulist_rows_selected)){return(NULL)}
if (length(input$menulist_rows_selected)>1){
showModal(
modalDialog(
title="Warning!",
"You can only edit one meal at a time. Deselect other rows."
)#end modalDialog
)#end showModal
}
if (!is.null(input$menulist_rows_selected) & length(input$menulist_rows_selected) == 1){
toEdit <- LOCAL$menu[as.numeric(input$menulist_rows_selected),] %>% select(UNIQUE_ID)
LOCAL$menuSelectedRows <- toEdit %>% pull(UNIQUE_ID)
LOCAL$editMeal <- LOCAL$lookup %>%
mutate(UNIQUE_ID = paste0(RIVER_DAY,'_',MEAL_ID)) %>%
filter(UNIQUE_ID %in% toEdit$UNIQUE_ID)
#Set editMode to TRUE
LOCAL$editMode<-TRUE
}#end if
}#end editMeal
#' @description Revises the menu dataframe to exclude the selected meal and ingredients.
#'
#' @param data The reactive values list common to all modules, named 'LOCAL'
#'
#' @param session,input,output Shiny session objects shared between all modules.
#'
#' @return The meal dataframe minus the selected meal and ingredients.
#'
#' @noRd
deleteMeal <- function(session,input,output, data = LOCAL){
LOCAL <- data
if (!is.null(input$menulist_rows_selected)) {
#Get meal IDs to kill
toKill <- LOCAL$menu[as.numeric(input$menulist_rows_selected),] %>% select(UNIQUE_ID)
#Kill them from the menu table
LOCAL$menu <- LOCAL$menu %>% filter(!UNIQUE_ID %in% toKill$UNIQUE_ID)
#Kill them from the menu ingView table
LOCAL$lookup <- LOCAL$lookup %>%
mutate(UNIQUE_ID = paste0(RIVER_DAY,'_',MEAL_ID)) %>%
filter(!UNIQUE_ID %in% toKill$UNIQUE_ID)
}#end if
}#end deleteMeal
#'
#' #Delete ingredient button add/edit----
#'
#' @description Action button to remove an ingredient from a meal in edit mode or in create new meal mode.
#' These actions are shown alternately in the same UI by if/else dependent on reactive value of LOCAL$editMode
#'
#' @param data The reactive values list common to all modules, named 'LOCAL'
#'
#' @param session,input,output Shiny session objects shared between all modules.
#'
#' @return The temporary edit meal dataframe minus the deleted ingredient(s).
#'
#' @noRd
deleteIngredient <- function(session,input,output, data = LOCAL){
LOCAL <- data
if(LOCAL$editMode == FALSE & !is.null(input$newMealView_rows_selected)){
LOCAL$newMeal <- LOCAL$newMeal[-as.numeric(input$newMealView_rows_selected),]
}
if (LOCAL$editMode == TRUE & !is.null(input$editView_rows_selected)) {
#Kill them from the meal ingredient table
LOCAL$editMeal <- LOCAL$editMeal[-as.numeric(input$editView_rows_selected),]
}#end if
}#end deleteIngredient
#'
#' #Cancel add/edit meal button----
#'
#' @description Cancel button clears work in progress and aborts the add/edit meal mode
#'
#' @param data The reactive values list common to all modules, named 'LOCAL'
#'
#' @param session,input,output Shiny session objects shared between all modules.
#'
#' @return Clears inputs in progress. An observer navigates back to main menu page..
#'
#' @noRd
cancelAddEdit <- function(session, input, output, data = LOCAL){
LOCAL <- data
if(LOCAL$editMode == FALSE){
#reset editMode to FALSE -- this is probably redundant
LOCAL$editMode <- FALSE
#Clear newMeal
LOCAL$newMeal <- data.frame()
#Clear input fields
updateTextInput(session,'newmealinput',value = '')
updatePickerInput(session, 'choosemealtype', selected = '--Select Meal Type--')
updateTextInput(session, 'newmealdesc',value = '')
} else
if(LOCAL$editMode == TRUE){
#reset editMode to FALSE
LOCAL$editMode <- FALSE
#Clear editMeal
LOCAL$editMeal <- data.frame()
}#end if
}#end cancelAddEdit
#'
#'
#' @title Commit add/edit meal
#'
#' @description The primary button to commit new meal or edited meal back to the main menu dataframe.
#' The UI is shared for add/edit modes by if/else dependent on LOCAL$editMode
#'
#' @param data The reactive values list common to all modules, named 'LOCAL'
#'
#' @param session,input,output Shiny session objects shared between all modules.
#'
#' @return The new meal is appended with unique ID number and appended to the working menu DF..
#'
#' @noRd
commitAddEdit <- function(session,input,output, data = LOCAL){
LOCAL <- data
if(LOCAL$editMode == FALSE){
validate(
need(input$newmealinput, 'Enter Meal Name'),
need(input$choosemealtype, 'Choose Meal Type'),
need(input$newmealdesc, 'Enter Meal Description')
)
#Add new MEAL_ID to newMeal
#Get new IDs from google to besure they are u to date
newIDs <- gsGetIDs()
#Append new meal df with new meal ID
LOCAL$newMeal <- LOCAL$newMeal %>%
mutate(
MEAL_ID = newIDs$nmID
)
#Append LOCA$lm Increment MEAL_ID +1 already happened
LOCAL$lm <- LOCAL$lm %>%
bind_rows(LOCAL$newMeal %>% select(MEAL_ID,MEAL_NAME,MEAL_TYPE,MEAL_DESCRIPTION) %>% unique(.))
#Append LOCAL$xrefIng with new meal and new ID and ingredients MEAL_ID +1 already happened
LOCAL$xrefIng <- LOCAL$xrefIng %>%
bind_rows(LOCAL$newMeal %>% select(INGREDIENT_ID,MEAL_ID,INGREDIENT, MEAL_NAME) %>% unique(.))
#Update viewMenuIngredients
LOCAL$viewMenuIngredients <- mkViewMenuIngredients(data = LOCAL)
}#end if
if(LOCAL$editMode == TRUE){
#DELETE THE OLD MEAL FROM LOCAL$menu, LOCAL$lookup
#Kill them from the menu table
LOCAL$menu <- LOCAL$menu %>% filter(!UNIQUE_ID %in% LOCAL$menuSelectedRows)
#Kill them from the menu ingView table
LOCAL$lookup <- LOCAL$lookup %>%
mutate(UNIQUE_ID = paste0(RIVER_DAY,'_',MEAL_ID)) %>%
filter(!UNIQUE_ID %in% LOCAL$menuSelectedRows)
#Update LOCAL$editMeal with inputs in case they changed, increment MEAL_ID, add UNIQUE_ID for row selection
#Get new IDs from google to besure they are u to date
newIDs <- gsGetIDs()
LOCAL$editMeal <- LOCAL$editMeal %>%
mutate(
MEAL_NAME = input$editmealname,
MEAL_ID = max(newIDs$nmID, max(LOCAL$lm$MEAL_ID) + 1),#Need to get max MEAL_ID from DB and LOCAL$lm$MEAL_ID then take the larger one
UNIQUE_ID = paste0(RIVER_DAY,'_',MEAL_ID),
MEAL_TYPE = input$choosemealtype,
MEAL_DESCRIPTION = input$editmealdesc,
MEAL_TYPE = factor(MEAL_TYPE, levels = LOCAL$lmt$MEAL_TYPE)
)
#Refresh selected meal id on planner page so it is selected back on menu page
LOCAL$menuSelectedRows <- LOCAL$editMeal %>% pull(UNIQUE_ID)
#Append LOCAL$lookup
LOCAL$lookup <- LOCAL$lookup %>%
bind_rows(LOCAL$editMeal) %>%
mutate(MEAL_TYPE = factor(MEAL_TYPE, levels = LOCAL$lmt$MEAL_TYPE))
#Append LOCAL$menu
LOCAL$menu <- LOCAL$menu %>%
bind_rows(
LOCAL$editMeal %>% select(RIVER_DAY,MEAL_TYPE,MEAL_NAME,NO_PEOPLE,MEAL_ID, UNIQUE_ID) %>% unique(.)
) %>%
mutate(MEAL_TYPE = factor(MEAL_TYPE, levels = LOCAL$lmt$MEAL_TYPE)) %>%
arrange(RIVER_DAY,MEAL_TYPE)
#Append LOCA$lm Increment MEAL_ID +1 already happened
LOCAL$lm <- LOCAL$lm %>%
bind_rows(
LOCAL$editMeal %>% select(MEAL_ID,MEAL_NAME,MEAL_TYPE,MEAL_DESCRIPTION) %>% unique(.)
)
#Append LOCAL$xrefIng with new meal and new ID and ingredients MEAL_ID +1 already happened
#TODO add in any revised SSF values
LOCAL$xrefIng <- LOCAL$xrefIng %>%
bind_rows(
LOCAL$editMeal %>% select(INGREDIENT_ID,MEAL_ID,INGREDIENT, MEAL_NAME, SERVING_SIZE_FACTOR)
)
#Update viewMenuIngredients
LOCAL$viewMenuIngredients <- mkViewMenuIngredients(data = LOCAL)
#reset editMode to FALSE
LOCAL$editMode <- FALSE
#Clear editMeal
LOCAL$editMeal <- data.frame()
}#end if
}#end commitAddEdit
#'
#' #MODAL BUTTONS----------------------------------------------
#'
#'
#' @description Button within modal for adding ingredints to a meal in add or edit mode.
#' The UI is taggled by the value of LOCAL$editMode
#'
#' @param data The reactive values list common to all modules, named 'LOCAL'
#'
#' @param session,input,output Shiny session objects shared between all modules.
#'
#' @return The return value, if any, from executing the function.
#'
#' @noRd
addIngredients <- function(session, input, output, data){
LOCAL <- data
if(LOCAL$editMode == FALSE & length(input$ingredients_rows_selected)>=1){
LOCAL$newMeal <- data.frame(
MEAL_NAME = input$newmealinput,
MEAL_TYPE = input$choosemealtype,
MEAL_DESCRIPTION = input$newmealdesc,
stringsAsFactors = FALSE
) %>%
bind_cols(LOCAL$li[input$ingredients_rows_selected,]) %>%
bind_rows(LOCAL$newMeal)
} else
if(LOCAL$editMode == TRUE & length(input$ingredients_rows_selected)>=1){
LOCAL$editMeal <- data.frame(
RIVER_DAY = LOCAL$editMeal$RIVER_DAY %>% unique(.),
NO_PEOPLE = LOCAL$editMeal$NO_PEOPLE %>% unique(.),
MEAL_TYPE = LOCAL$editMeal$MEAL_TYPE %>% unique(.),
MEAL_NAME = LOCAL$editMeal$MEAL_NAME %>% unique(.),
MEAL_DESCRIPTION = LOCAL$editMeal$MEAL_DESCRIPTION %>% unique(.),
MEAL_ID = LOCAL$editMeal$MEAL_ID %>% unique(.),
UNIQUE_ID = LOCAL$editMeal$UNIQUE_ID %>% unique(.)
) %>%
bind_cols(LOCAL$li[input$ingredients_rows_selected,]) %>%
mutate(QUANTITY = round_any(SERVING_SIZE_FACTOR*NO_PEOPLE,1,ceiling), REVISED = '') %>%
select(.,all_of(names(LOCAL$editMeal))) %>%
bind_rows(LOCAL$editMeal)
}#end if else
removeModal()
}#end addIngredients
#'
#' #Choose update all SSF or update this meal only buttons from the edit quantity modal----
#'
#' @description Modal Button action. Update all serving size factors backcalculated by quantity edit.
#' Updates all instances of this ingredient in the session with revised serving size factor used to calculate quantity.
#'
#' @param data The reactive values list common to all modules, named 'LOCAL'
#'
#' @param session,input,output Shiny session objects shared between all modules.
#'
#' @return Updates SSF in current menu, ingredient list, and meal/ingredient XREF dataframes
#'
#' @noRd
updateAllSSF <- function(session,input,output,data = LOCAL){
LOCAL <- data
row <- input$editView_cell_edit$row
LOCAL$editMeal[row,10] <- (LOCAL$editMeal[row,6]/LOCAL$editMeal[row,9])#Backcalculate SSF
newSSF <- LOCAL$editMeal[row,10]
ingID <- LOCAL$editMeal[row,13]
#TODO here may need instead append LOCAL$li with the revised SSF as a new ingredient/ingredient_id
LOCAL$li <- LOCAL$li %>% mutate(SERVING_SIZE_FACTOR = case_when(INGREDIENT_ID == ingID ~ newSSF, TRUE ~ SERVING_SIZE_FACTOR))
if(nrow(LOCAL$lookup)>0){
LOCAL$lookup <- LOCAL$lookup %>% mutate(
SERVING_SIZE_FACTOR = case_when(INGREDIENT_ID == ingID ~ newSSF, TRUE ~ SERVING_SIZE_FACTOR),
QUANTITY = case_when(INGREDIENT_ID == ingID ~ newSSF*NO_PEOPLE, TRUE ~ QUANTITY),
REVISED = case_when(INGREDIENT_ID == ingID ~ paste(REVISED,'changed_QTYandSSF'), TRUE ~ REVISED)
)#end LOCAL$lookup
}#end if
removeModal()
}#end updateAllSSF
#'
#' #No Update All SSF button on editQuantityModal
#'
#' @description Modal Button action. Updates serving size factor backcalculated from edited quantity
#' only in the current edited meal, not the everywhere in the session dataframes.
#'
#' @param data The reactive values list common to all modules, named 'LOCAL'
#'
#' @param session,input,output Shiny session objects shared between all modules.
#'
#' @return Updated backcalculated SSF for the current meal only..
#'
#' @noRd
noUpdateAllSSF <- function(session,input,output,data = LOCAL){
LOCAL <- data
row <- input$editView_cell_edit$row
LOCAL$editMeal[row,10] <- (LOCAL$editMeal[row,6]/LOCAL$editMeal[row,9])#This calculates a new SSF just for this meal
removeModal()
}#end noUpdateAllSSF
#'
#' #MODALS------------------------------------------------------------
#' Edit quantity warning and decision modal
#'
#' @description A modal presented when an ingredient quantity is changed in edit mode.
#' The user decides whether to propagate the change via backcalculation of SSF
#' throughout the spp, or just for the current meal.
#'
#' @param ing The ingredient name being edited to be dsplayed in the modal message.
#'
#' @param session Shiny session object shared between all modules.
#'
#' @return Renders the explanation modal, and the decision buttons.
#'
#' @noRd
editQuantityModal <- function(session,ing) {
ns <- session$ns
modalDialog(
p(paste0('You edited quantity of ',ing,'. Do you want to use an associated modified serving size factor for other instances of ',
ing,' for the whole session? This could save additional editing if you use ',ing,' again.')),
#p(paste0("The serving size factor will be update for ",as.character(LOCAL$editMeal[row,5]),". Do you want to adjust this for all instances of ",as.character(LOCAL$editMeal[row,5]),"?")),
title = 'You are editing a quantity.',
footer = tags$div(class = "btn_group",
actionButton(ns("updateIngredientSSF"), "Update Throughout"),
actionButton(ns("noUpdateIngredientSSF"), "This Meal Only")
),#end div
easyClose = FALSE
)#end modalDialog
}#end editQuantityModal()
#'
#' #Add ingredient modal----
#'
#' @description The modal displayed when selecting/adding an ingredient to a new meal of editing meal.
#' The modal is shared between add/edit mode UI, dependent on LOCAL$editMode
#'
#' @param data The reactive values list common to all modules, named 'LOCAL'
#'
#' @param session,input,output Shiny session objects shared between all modules.
#'
#' @return Displays list of ingredients to select. Adds the selected ingredients to the meal in progress..
#'
#' @noRd
addIngredientModal <- function(session,input,output,data){
ns <- session$ns
LOCAL <- data
showModal(
modalDialog(
fluidPage(
fluidRow(
column(width = 12,
h1(paste('Select Ingredients for',ifelse(LOCAL$editMode == FALSE,input$newmealinput,input$editmealname)))
),#end column
),#end fluidRow
fluidRow(
column(width = 12,
DTOutput(ns('ingredients'))
)#end column
)#end fluidRow
),#end fluidPage
title = 'Select Ingredients',
size = 'l',
easyClose = FALSE,
footer = tags$div(class = "btn_group",
btn_panelItem(ns('modalAddIngredient'),lbl='Add',icn = "plus", class = "btn-success"),
btn_panelItem(ns('modalCancel'),lbl='Cancel',icn = NULL, class = "btn-default"),
),#end div
)#end modalDialog
)#end showModal
LOCAL$li <- LOCAL$li %>% mutate(
INGREDIENT_CATEGORY = factor(INGREDIENT_CATEGORY, levels = unique(INGREDIENT_CATEGORY)),
INGREDIENT = factor(INGREDIENT, levels = unique(INGREDIENT))
)
}#end addIngredientModal
#'
#'
#'New meal modal
#' @description The modal displayed when committing a new meal. The user is asked to share with the database
#' or just use in this session
#'
#' @param session,input,output Shiny session objects shared between all modules.
#'
#' @return If share is selected, data are also written to the database. If not, they are written to the session only.
#'
#' @noRd
newMealModal <- function(session,input,output){
ns <- session$ns
showModal(
modalDialog(
'You created a new meal! Your new meal is now available to add via the Meal Type and Meal Name dropdowns.
\nWould you like to share this meal also to the public database?'
,#end message
title = 'New Meal Created',
size = 'm',
easyClose = FALSE,
footer = tags$div(class = "btn_group",
btn_panelItem(ns('modalCommitNewMeal'),lbl='Share',icn = "plus", class = "btn-success"),
btn_panelItem(ns('modalThisMenuOnly'),lbl='This Menu Only',icn = NULL, class = "btn-default"),
),#end div
)#end modalDialog
)#end showModal
}#end newMealModal
#'
#'New ingredient modal
#' @description The modal displayed when committing a new ingredient. The user is asked to share with the database
#' or just use in this session
#'
#' @param session,input,output Shiny session objects shared between all modules.
#'
#' @return If share is selected, data are also written to the database. If not, they are written to the session only.
#'
#' @noRd
newIngredientModal <- function(session,input,output){
ns <- session$ns
showModal(
modalDialog(
p('You created a new ingredient! Your new ingredient is now available to add to meals.'),
p('Would you like to share this ingredient also to the public database?')
,#end message
title = 'New Ingredient Created',
size = 'm',
easyClose = FALSE,
footer = tags$div(class = "btn_group",
btn_panelItem(ns('modalCommitNewIng'),lbl='Share',icn = "plus", class = "btn-success"),
btn_panelItem(ns('modalThisMenuOnly'),lbl='This Menu Only',icn = NULL, class = "btn-default"),
),#end div
)#end modalDialog
)#end showModal
}#end newIngredientModal
#'
#'Commit new ingredient
#' @description The modal displayed when commiting a new ingredient.
#'
#' @param data The reactive values list common to all modules, named 'LOCAL'
#'
#' @param session,input,output Shiny session objects shared between all modules.
#'
#' @return If share is selected, data are also written to the database. If not, they are written to the session only..
#'
#' @noRd
commitNewIngredient <- function(session,input,output,data){
ns <- session$ns
LOCAL <- data
LOCAL$li <- LOCAL$newIngredient %>%
select(names(LOCAL$li)) %>%
# mutate(
# SERVING_SIZE_FACTOR = as.numeric(SERVING_SIZE_FACTOR),
# INGREDIENT_ID = gsGetIDs()[[2]]#Getting latest next ingredient ID from DB
# ) %>%
bind_rows(LOCAL$li) %>%
mutate(
INGREDIENT_CATEGORY = factor(INGREDIENT_CATEGORY, levels = unique(INGREDIENT_CATEGORY)),
INGREDIENT = factor(INGREDIENT, levels = unique(INGREDIENT)),
STORAGE_DESCRIPTION = factor(STORAGE_DESCRIPTION, levels = unique(STORAGE_DESCRIPTION)),
)#end mutate
}#end commitNewIngredient
peernisse/riverMenu documentation built on Aug. 31, 2022, 7:39 p.m.
R Package Documentation
Browse R Packages
We want your feedback!
Note that we can't provide technical support on individual packages. You should contact the package authors for that.
Defines functions mkLocalLookup filterPickMealType pickMealType mkViewMenuIngredients gsGetIDs read_gs
# Define database Connection info and store database location string in global environment
dbURL <<- 'https://docs.google.com/spreadsheets/d/1qbWU0Ix6VrUumYObYyddZ1NvCTEjVk18VeWxbvrw5iY/edit?usp=sharing'
#' @title Read Google Sheets
#' @name read_gs
#'
#' @description reads googlesheets data on app startup
#'
#' @return database menu tables
#'
#' @noRd
read_gs<-function(db = dbURL){
'<<-' <- XREF_INGREDIENT <- LU_MEAL_TYPE <- LU_MEAL <- LU_INGREDIENTS <- NULL
url <- db
XREF_INGREDIENT <<- googlesheets4::read_sheet(url, sheet = "XREF_INGREDIENT")
LU_MEAL_TYPE <<- googlesheets4::read_sheet(url, sheet = "LU_MEAL_TYPE")
LU_MEAL <<- googlesheets4::read_sheet(url, sheet = 'LU_MEAL')
LU_INGREDIENTS <<- googlesheets4::read_sheet(url, sheet = "LU_INGREDIENTS")
}
#'Function to get new meal and ingredient IDs prior to appending new data
#' @description Gets max ingredient and meal IDs + 1 to use for adding new items to datatbase
#'
#' @param cache The location of the gs4_auth secret to authenticate
#'
#' @param email The developer email to use for the google sheets account auth
#'
#' @return Returns a list of 2 new IDs, one for ingredient and one for meal
#'
#' @noRd
gsGetIDs <- function(db = dbURL){
'<<-' <- XREF_INGREDIENT <- LU_MEAL_TYPE <- LU_MEAL <- LU_INGREDIENTS <- NULL #This is here to solve errors in package checking
url <- db
nmID <- googlesheets4::read_sheet(url, sheet = "LU_MEAL")[['MEAL_ID']] %>% max() + 1
niID <- googlesheets4::read_sheet(url, sheet = "LU_INGREDIENTS")[['INGREDIENT_ID']] %>% max() + 1
out<- list(nmID = nmID, niID = niID)
return(out)
}#end gsGetIDs
#' make view menu ingredients dataframe
#' @description Creates and updates all meals dataframe for appending new meals
#'
#' @param data The reactive values list common to all modules.
#'
#' @return dataframe of all existing meals in the database.
#'
#' @noRd
mkViewMenuIngredients <- function(data){
LOCAL <- data
LOCAL$viewMenuIngredients <- LOCAL$xrefIng %>%
inner_join(LOCAL$lm) %>%
inner_join(LOCAL$li, by = c("INGREDIENT_ID", "INGREDIENT"))
if ('SERVING_SIZE_FACTOR.x' %in% names(LOCAL$viewMenuIngredients)){
LOCAL$viewMenuIngredients <- LOCAL$viewMenuIngredients %>%
mutate(SERVING_SIZE_FACTOR = case_when(
!is.na(SERVING_SIZE_FACTOR.x) ~ SERVING_SIZE_FACTOR.x,
TRUE ~ SERVING_SIZE_FACTOR.y
)#end case_when
)#end mutate
}#end if
LOCAL$viewMenuIngredients <- LOCAL$viewMenuIngredients %>%
select(MEAL_NAME,MEAL_TYPE,MEAL_DESCRIPTION,INGREDIENT,INGREDIENT_DESCRIPTION,SERVING_SIZE_DESCRIPTION,
SERVING_SIZE_FACTOR,MEAL_ID,INGREDIENT_ID) %>%
arrange(MEAL_NAME,INGREDIENT)
return(LOCAL$viewMenuIngredients)
}
#'
#' Pick meal type picker
#' @description Reused function for picker input pick meal type. Designed to be used inside renderUI in the server function
#'
#' @param data The reactive values list common to all modules
#'
#' @param control The id for the picker input
#'
#' @param label The label for the picker input
#'
#' @param selected The selected value for the picker input
#'
#' @param session,input,output Shiny session objects shared between all modules.
#'
#' @return UI picker input for meal type
#'
#' @noRd
pickMealType <- function(session,input,output,data,control = 'choosemealtype',label,selected = '--Select Meal Type--'){
LOCAL <- data
output$lumtype2<-renderUI({
ns<-session$ns
pickerInput(
ns(control),label = label,
selected = selected,
choices = c('--Select Meal Type--',isolate(LOCAL$lmt %>% pull(MEAL_TYPE)))
)
})#End lu meal type
}#end pickMealType
#'
#'
#' filterPickMealType
#'
#' @description Logic for cascading filterable picker lists
#'
#' @param data The reactive values list common to all modules
#'
#' @param session,input,output Shiny session objects shared between all modules.
#'
#' @return Updated picker choices.
#'
#' @noRd
filterPickMealType <- function(session,input,output,data){
LOCAL <- data
mls<-LOCAL$lm %>%
filter(MEAL_TYPE %in% input$choosemealtype) %>%
pull(MEAL_NAME) %>%
as.character() %>%
sort()
prompt<-ifelse(
input$choosemealtype == '--Select Meal Type--',
'--Select Meal Type First--',
paste0('--Select ',input$choosemealtype,'--')
)#End ifelse
updatePickerInput(session,'choosemeal',label='Meal Name',
selected = prompt,
choices = c(prompt,mls))
}#end filterPickMealType
#'
#' #Make first LOCAL$lookup
#'
#' @description Instantiates the main reactive values dataframe that holds the
#' menu being built
#'
#' @param data The reactive values list common to all modules
#'
#' @param newLine Receives a one row dataframe of user input to be built out
#' into the full menu entry
#'
#' @param session,input,output Shiny session objects shared between all modules.
#'
#' @return The main reactive value dataframe of the menu building session.
#'
#' @noRd
mkLocalLookup <- function(session,input,output,data, newLine = NULL){
LOCAL <- data
#Create main menu dataframe for the session
llOut<-newLine %>% #this gets the river day in case meals are repeated on the trip
mutate(NO_PEOPLE = as.numeric(NO_PEOPLE)) %>%
left_join(LOCAL$viewMenuIngredients, by = c('MEAL_NAME' = 'MEAL_NAME','MEAL_TYPE' = 'MEAL_TYPE')) %>%
as.data.frame(.) %>%
mutate(QUANTITY = round_any(SERVING_SIZE_FACTOR*NO_PEOPLE,1,ceiling), REVISED = '') %>%
select(RIVER_DAY,MEAL_TYPE,MEAL_NAME,MEAL_DESCRIPTION,INGREDIENT,QUANTITY,INGREDIENT_DESCRIPTION,SERVING_SIZE_DESCRIPTION,
NO_PEOPLE,SERVING_SIZE_FACTOR,REVISED,MEAL_ID,INGREDIENT_ID) %>%
bind_rows(LOCAL$lookup) %>%
as.data.frame(.) %>%
mutate(#This sets factors so the table filter dropdowns appears
RIVER_DAY = factor(RIVER_DAY, levels = seq(min(RIVER_DAY),max(RIVER_DAY),1)),
MEAL_NAME = factor(MEAL_NAME, levels = unique(MEAL_NAME)),
INGREDIENT = factor(INGREDIENT, levels = unique(INGREDIENT)),
MEAL_TYPE = factor(MEAL_TYPE,levels = LOCAL$lmt$MEAL_TYPE)
) %>% #end mutate
arrange(RIVER_DAY,MEAL_TYPE)
return(llOut)
}#end function
#'@description A wrapper of datatable() to create a datatable to be output with renderDT
#'
#'@param df The dataframe to be in the datatable
#'
#'@param edit Logical Whether the datatable will be editable
#'
#'@param filter The location of the filter in the rendered table. Default to 'none'
#'
#'@param dom The datatable options argument for which DOM objects to show in the rendered table
#'
#'@param scrollY The height of the output table in pixels whereby a scroll bar is grown.
#'
#'@param session Shiny session object shared between all modules.
#'
#'@return The datatable configured to be output via renderDT.
#'
#' @noRd
dtStyle1 <- function(session,df,edit = TRUE, filter = 'none', dom = 't',scrollY = '400px'){
datatable(
data = df,
rownames = FALSE,
style = "bootstrap",
filter = filter,
editable = edit,
options = list(fixedHeader = TRUE, pageLength = 1000, scrollX = TRUE, scrollY = scrollY, dom = dom)
)#end datatable
}#end function dtStyle1
#'
#' Add meal to the menu. Takes user input and combines with stored ingredients to create the main working
#' dataframe for the tool.
#'
#' @description The button to commit a selected meal to the main menu reactive value dataframe
#'
#' @param data The reactive values list common to all modules
#'
#' @param session,input,output Shiny session objects shared between all modules.
#'
#' @return A meal selection and associated ingredient are modified by number of people
#' and added to the menu
#'
#' @noRd
addMeal<-function(session,input,output, data){
LOCAL <- data
if(nrow(LOCAL$menu)>0){
mealCheck<-LOCAL$menu %>%
mutate(uniqueDay_MT_MN = paste(RIVER_DAY,MEAL_TYPE,MEAL_NAME)) %>%
select(uniqueDay_MT_MN) %>%
unique(.) %>%
as.data.frame(.)
} else {
mealCheck<-data.frame(uniqueDay_MT_MN = '')
}
#Check for same meal same day
#Require river day input
if(input$riverday == "" | is.na(as.numeric(input$riverday))==TRUE){
showModal(modalDialog(
title="Warning!",
"Select a river day"
))
return(NULL)
} else
if(input$nopeople == "" | is.na(as.numeric(input$nopeople))==TRUE){
showModal(modalDialog(
title="Warning!",
"Select number of people"
))
return(NULL)
} else
if(paste(input$riverday,input$choosemealtype,input$choosemeal) %in% mealCheck$uniqueDay_MT_MN){
showModal(modalDialog(
title = "Day and Meal Conflict",
"This meal exists on this day already",
easyClose = TRUE
))
return(NULL)
} else {
#Create new meal DF from inputs
LOCAL$newLine <- data.frame(
RIVER_DAY = input$riverday,
MEAL_TYPE = input$choosemealtype,
MEAL_NAME = input$choosemeal,
NO_PEOPLE = as.numeric(input$nopeople),
stringsAsFactors = FALSE
)
#Create main menu tables for the session----------------------
#Create local view menu ingredients with everything in it
LOCAL$viewMenuIngredients <- mkViewMenuIngredients(data = LOCAL)
LOCAL$lookup <- mkLocalLookup(session,input,output,data = LOCAL, newLine = LOCAL$newLine)
#Menu Overview
LOCAL$menu <- LOCAL$lookup %>%
select(RIVER_DAY,MEAL_TYPE,MEAL_NAME,NO_PEOPLE,MEAL_ID) %>%
unique(.)
#select current meal
#Create unique id for day and meal ID
LOCAL$menu <- LOCAL$menu %>% mutate(UNIQUE_ID = paste0(RIVER_DAY,'_',MEAL_ID))
#Get the row numbers where this unique id is
LOCAL$menuSelectedRows <- LOCAL$menu[which(LOCAL$menu$MEAL_NAME == input$choosemeal),] %>% pull(UNIQUE_ID) %>% tail(.,1)
#LOCAL$menuFilter <- LOCAL$menu %>% .[LOCAL$menuSelectedRows,]
#Reset meal type and meal name pickers
updatePickerInput(session,'choosemealtype',selected = '--Select Meal Type--',
choices = c('--Select Meal Type--',LOCAL$lmt$MEAL_TYPE))
#kill LOCAL$newLine
LOCAL$newLine <- data.frame()
}#end if else
}#end addMeal button function
#'
#' Edit meal button. User can edit one meal at a time, if one meal is selected this button begins edit mode.
#'
#' @description Begins meal edit mode. Generates temporary dataframe of one meal
#' to be edited then put back in the main menu.
#'
#' @param data The reactive values list common to all modules, named 'LOCAL'. Default value is 'LOCAL'
#'
#' @param session,input,output Shiny session objects shared between all modules.
#'
#' @return A temporary meal dataframe containing one meal and ingredients to be edited.
#'
#' @noRd
editMeal <- function(session,input,output, data = LOCAL){
LOCAL <- data
if (is.null(input$menulist_rows_selected)){return(NULL)}
if (length(input$menulist_rows_selected)>1){
showModal(
modalDialog(
title="Warning!",
"You can only edit one meal at a time. Deselect other rows."
)#end modalDialog
)#end showModal
}
if (!is.null(input$menulist_rows_selected) & length(input$menulist_rows_selected) == 1){
toEdit <- LOCAL$menu[as.numeric(input$menulist_rows_selected),] %>% select(UNIQUE_ID)
LOCAL$menuSelectedRows <- toEdit %>% pull(UNIQUE_ID)
LOCAL$editMeal <- LOCAL$lookup %>%
mutate(UNIQUE_ID = paste0(RIVER_DAY,'_',MEAL_ID)) %>%
filter(UNIQUE_ID %in% toEdit$UNIQUE_ID)
#Set editMode to TRUE
LOCAL$editMode<-TRUE
}#end if
}#end editMeal
#' @description Revises the menu dataframe to exclude the selected meal and ingredients.
#'
#' @param data The reactive values list common to all modules, named 'LOCAL'
#'
#' @param session,input,output Shiny session objects shared between all modules.
#'
#' @return The meal dataframe minus the selected meal and ingredients.
#'
#' @noRd
deleteMeal <- function(session,input,output, data = LOCAL){
LOCAL <- data
if (!is.null(input$menulist_rows_selected)) {
#Get meal IDs to kill
toKill <- LOCAL$menu[as.numeric(input$menulist_rows_selected),] %>% select(UNIQUE_ID)
#Kill them from the menu table
LOCAL$menu <- LOCAL$menu %>% filter(!UNIQUE_ID %in% toKill$UNIQUE_ID)
#Kill them from the menu ingView table
LOCAL$lookup <- LOCAL$lookup %>%
mutate(UNIQUE_ID = paste0(RIVER_DAY,'_',MEAL_ID)) %>%
filter(!UNIQUE_ID %in% toKill$UNIQUE_ID)
}#end if
}#end deleteMeal
#'
#' #Delete ingredient button add/edit----
#'
#' @description Action button to remove an ingredient from a meal in edit mode or in create new meal mode.
#' These actions are shown alternately in the same UI by if/else dependent on reactive value of LOCAL$editMode
#'
#' @param data The reactive values list common to all modules, named 'LOCAL'
#'
#' @param session,input,output Shiny session objects shared between all modules.
#'
#' @return The temporary edit meal dataframe minus the deleted ingredient(s).
#'
#' @noRd
deleteIngredient <- function(session,input,output, data = LOCAL){
LOCAL <- data
if(LOCAL$editMode == FALSE & !is.null(input$newMealView_rows_selected)){
LOCAL$newMeal <- LOCAL$newMeal[-as.numeric(input$newMealView_rows_selected),]
}
if (LOCAL$editMode == TRUE & !is.null(input$editView_rows_selected)) {
#Kill them from the meal ingredient table
LOCAL$editMeal <- LOCAL$editMeal[-as.numeric(input$editView_rows_selected),]
}#end if
}#end deleteIngredient
#'
#' #Cancel add/edit meal button----
#'
#' @description Cancel button clears work in progress and aborts the add/edit meal mode
#'
#' @param data The reactive values list common to all modules, named 'LOCAL'
#'
#' @param session,input,output Shiny session objects shared between all modules.
#'
#' @return Clears inputs in progress. An observer navigates back to main menu page..
#'
#' @noRd
cancelAddEdit <- function(session, input, output, data = LOCAL){
LOCAL <- data
if(LOCAL$editMode == FALSE){
#reset editMode to FALSE -- this is probably redundant
LOCAL$editMode <- FALSE
#Clear newMeal
LOCAL$newMeal <- data.frame()
#Clear input fields
updateTextInput(session,'newmealinput',value = '')
updatePickerInput(session, 'choosemealtype', selected = '--Select Meal Type--')
updateTextInput(session, 'newmealdesc',value = '')
} else
if(LOCAL$editMode == TRUE){
#reset editMode to FALSE
LOCAL$editMode <- FALSE
#Clear editMeal
LOCAL$editMeal <- data.frame()
}#end if
}#end cancelAddEdit
#'
#'
#' @title Commit add/edit meal
#'
#' @description The primary button to commit new meal or edited meal back to the main menu dataframe.
#' The UI is shared for add/edit modes by if/else dependent on LOCAL$editMode
#'
#' @param data The reactive values list common to all modules, named 'LOCAL'
#'
#' @param session,input,output Shiny session objects shared between all modules.
#'
#' @return The new meal is appended with unique ID number and appended to the working menu DF..
#'
#' @noRd
commitAddEdit <- function(session,input,output, data = LOCAL){
LOCAL <- data
if(LOCAL$editMode == FALSE){
validate(
need(input$newmealinput, 'Enter Meal Name'),
need(input$choosemealtype, 'Choose Meal Type'),
need(input$newmealdesc, 'Enter Meal Description')
)
#Add new MEAL_ID to newMeal
#Get new IDs from google to besure they are u to date
newIDs <- gsGetIDs()
#Append new meal df with new meal ID
LOCAL$newMeal <- LOCAL$newMeal %>%
mutate(
MEAL_ID = newIDs$nmID
)
#Append LOCA$lm Increment MEAL_ID +1 already happened
LOCAL$lm <- LOCAL$lm %>%
bind_rows(LOCAL$newMeal %>% select(MEAL_ID,MEAL_NAME,MEAL_TYPE,MEAL_DESCRIPTION) %>% unique(.))
#Append LOCAL$xrefIng with new meal and new ID and ingredients MEAL_ID +1 already happened
LOCAL$xrefIng <- LOCAL$xrefIng %>%
bind_rows(LOCAL$newMeal %>% select(INGREDIENT_ID,MEAL_ID,INGREDIENT, MEAL_NAME) %>% unique(.))
#Update viewMenuIngredients
LOCAL$viewMenuIngredients <- mkViewMenuIngredients(data = LOCAL)
}#end if
if(LOCAL$editMode == TRUE){
#DELETE THE OLD MEAL FROM LOCAL$menu, LOCAL$lookup
#Kill them from the menu table
LOCAL$menu <- LOCAL$menu %>% filter(!UNIQUE_ID %in% LOCAL$menuSelectedRows)
#Kill them from the menu ingView table
LOCAL$lookup <- LOCAL$lookup %>%
mutate(UNIQUE_ID = paste0(RIVER_DAY,'_',MEAL_ID)) %>%
filter(!UNIQUE_ID %in% LOCAL$menuSelectedRows)
#Update LOCAL$editMeal with inputs in case they changed, increment MEAL_ID, add UNIQUE_ID for row selection
#Get new IDs from google to besure they are u to date
newIDs <- gsGetIDs()
LOCAL$editMeal <- LOCAL$editMeal %>%
mutate(
MEAL_NAME = input$editmealname,
MEAL_ID = max(newIDs$nmID, max(LOCAL$lm$MEAL_ID) + 1),#Need to get max MEAL_ID from DB and LOCAL$lm$MEAL_ID then take the larger one
UNIQUE_ID = paste0(RIVER_DAY,'_',MEAL_ID),
MEAL_TYPE = input$choosemealtype,
MEAL_DESCRIPTION = input$editmealdesc,
MEAL_TYPE = factor(MEAL_TYPE, levels = LOCAL$lmt$MEAL_TYPE)
)
#Refresh selected meal id on planner page so it is selected back on menu page
LOCAL$menuSelectedRows <- LOCAL$editMeal %>% pull(UNIQUE_ID)
#Append LOCAL$lookup
LOCAL$lookup <- LOCAL$lookup %>%
bind_rows(LOCAL$editMeal) %>%
mutate(MEAL_TYPE = factor(MEAL_TYPE, levels = LOCAL$lmt$MEAL_TYPE))
#Append LOCAL$menu
LOCAL$menu <- LOCAL$menu %>%
bind_rows(
LOCAL$editMeal %>% select(RIVER_DAY,MEAL_TYPE,MEAL_NAME,NO_PEOPLE,MEAL_ID, UNIQUE_ID) %>% unique(.)
) %>%
mutate(MEAL_TYPE = factor(MEAL_TYPE, levels = LOCAL$lmt$MEAL_TYPE)) %>%
arrange(RIVER_DAY,MEAL_TYPE)
#Append LOCA$lm Increment MEAL_ID +1 already happened
LOCAL$lm <- LOCAL$lm %>%
bind_rows(
LOCAL$editMeal %>% select(MEAL_ID,MEAL_NAME,MEAL_TYPE,MEAL_DESCRIPTION) %>% unique(.)
)
#Append LOCAL$xrefIng with new meal and new ID and ingredients MEAL_ID +1 already happened
#TODO add in any revised SSF values
LOCAL$xrefIng <- LOCAL$xrefIng %>%
bind_rows(
LOCAL$editMeal %>% select(INGREDIENT_ID,MEAL_ID,INGREDIENT, MEAL_NAME, SERVING_SIZE_FACTOR)
)
#Update viewMenuIngredients
LOCAL$viewMenuIngredients <- mkViewMenuIngredients(data = LOCAL)
#reset editMode to FALSE
LOCAL$editMode <- FALSE
#Clear editMeal
LOCAL$editMeal <- data.frame()
}#end if
}#end commitAddEdit
#'
#' #MODAL BUTTONS----------------------------------------------
#'
#'
#' @description Button within modal for adding ingredints to a meal in add or edit mode.
#' The UI is taggled by the value of LOCAL$editMode
#'
#' @param data The reactive values list common to all modules, named 'LOCAL'
#'
#' @param session,input,output Shiny session objects shared between all modules.
#'
#' @return The return value, if any, from executing the function.
#'
#' @noRd
addIngredients <- function(session, input, output, data){
LOCAL <- data
if(LOCAL$editMode == FALSE & length(input$ingredients_rows_selected)>=1){
LOCAL$newMeal <- data.frame(
MEAL_NAME = input$newmealinput,
MEAL_TYPE = input$choosemealtype,
MEAL_DESCRIPTION = input$newmealdesc,
stringsAsFactors = FALSE
) %>%
bind_cols(LOCAL$li[input$ingredients_rows_selected,]) %>%
bind_rows(LOCAL$newMeal)
} else
if(LOCAL$editMode == TRUE & length(input$ingredients_rows_selected)>=1){
LOCAL$editMeal <- data.frame(
RIVER_DAY = LOCAL$editMeal$RIVER_DAY %>% unique(.),
NO_PEOPLE = LOCAL$editMeal$NO_PEOPLE %>% unique(.),
MEAL_TYPE = LOCAL$editMeal$MEAL_TYPE %>% unique(.),
MEAL_NAME = LOCAL$editMeal$MEAL_NAME %>% unique(.),
MEAL_DESCRIPTION = LOCAL$editMeal$MEAL_DESCRIPTION %>% unique(.),
MEAL_ID = LOCAL$editMeal$MEAL_ID %>% unique(.),
UNIQUE_ID = LOCAL$editMeal$UNIQUE_ID %>% unique(.)
) %>%
bind_cols(LOCAL$li[input$ingredients_rows_selected,]) %>%
mutate(QUANTITY = round_any(SERVING_SIZE_FACTOR*NO_PEOPLE,1,ceiling), REVISED = '') %>%
select(.,all_of(names(LOCAL$editMeal))) %>%
bind_rows(LOCAL$editMeal)
}#end if else
removeModal()
}#end addIngredients
#'
#' #Choose update all SSF or update this meal only buttons from the edit quantity modal----
#'
#' @description Modal Button action. Update all serving size factors backcalculated by quantity edit.
#' Updates all instances of this ingredient in the session with revised serving size factor used to calculate quantity.
#'
#' @param data The reactive values list common to all modules, named 'LOCAL'
#'
#' @param session,input,output Shiny session objects shared between all modules.
#'
#' @return Updates SSF in current menu, ingredient list, and meal/ingredient XREF dataframes
#'
#' @noRd
updateAllSSF <- function(session,input,output,data = LOCAL){
LOCAL <- data
row <- input$editView_cell_edit$row
LOCAL$editMeal[row,10] <- (LOCAL$editMeal[row,6]/LOCAL$editMeal[row,9])#Backcalculate SSF
newSSF <- LOCAL$editMeal[row,10]
ingID <- LOCAL$editMeal[row,13]
#TODO here may need instead append LOCAL$li with the revised SSF as a new ingredient/ingredient_id
LOCAL$li <- LOCAL$li %>% mutate(SERVING_SIZE_FACTOR = case_when(INGREDIENT_ID == ingID ~ newSSF, TRUE ~ SERVING_SIZE_FACTOR))
if(nrow(LOCAL$lookup)>0){
LOCAL$lookup <- LOCAL$lookup %>% mutate(
SERVING_SIZE_FACTOR = case_when(INGREDIENT_ID == ingID ~ newSSF, TRUE ~ SERVING_SIZE_FACTOR),
QUANTITY = case_when(INGREDIENT_ID == ingID ~ newSSF*NO_PEOPLE, TRUE ~ QUANTITY),
REVISED = case_when(INGREDIENT_ID == ingID ~ paste(REVISED,'changed_QTYandSSF'), TRUE ~ REVISED)
)#end LOCAL$lookup
}#end if
removeModal()
}#end updateAllSSF
#'
#' #No Update All SSF button on editQuantityModal
#'
#' @description Modal Button action. Updates serving size factor backcalculated from edited quantity
#' only in the current edited meal, not the everywhere in the session dataframes.
#'
#' @param data The reactive values list common to all modules, named 'LOCAL'
#'
#' @param session,input,output Shiny session objects shared between all modules.
#'
#' @return Updated backcalculated SSF for the current meal only..
#'
#' @noRd
noUpdateAllSSF <- function(session,input,output,data = LOCAL){
LOCAL <- data
row <- input$editView_cell_edit$row
LOCAL$editMeal[row,10] <- (LOCAL$editMeal[row,6]/LOCAL$editMeal[row,9])#This calculates a new SSF just for this meal
removeModal()
}#end noUpdateAllSSF
#'
#' #MODALS------------------------------------------------------------
#' Edit quantity warning and decision modal
#'
#' @description A modal presented when an ingredient quantity is changed in edit mode.
#' The user decides whether to propagate the change via backcalculation of SSF
#' throughout the spp, or just for the current meal.
#'
#' @param ing The ingredient name being edited to be dsplayed in the modal message.
#'
#' @param session Shiny session object shared between all modules.
#'
#' @return Renders the explanation modal, and the decision buttons.
#'
#' @noRd
editQuantityModal <- function(session,ing) {
ns <- session$ns
modalDialog(
p(paste0('You edited quantity of ',ing,'. Do you want to use an associated modified serving size factor for other instances of ',
ing,' for the whole session? This could save additional editing if you use ',ing,' again.')),
#p(paste0("The serving size factor will be update for ",as.character(LOCAL$editMeal[row,5]),". Do you want to adjust this for all instances of ",as.character(LOCAL$editMeal[row,5]),"?")),
title = 'You are editing a quantity.',
footer = tags$div(class = "btn_group",
actionButton(ns("updateIngredientSSF"), "Update Throughout"),
actionButton(ns("noUpdateIngredientSSF"), "This Meal Only")
),#end div
easyClose = FALSE
)#end modalDialog
}#end editQuantityModal()
#'
#' #Add ingredient modal----
#'
#' @description The modal displayed when selecting/adding an ingredient to a new meal of editing meal.
#' The modal is shared between add/edit mode UI, dependent on LOCAL$editMode
#'
#' @param data The reactive values list common to all modules, named 'LOCAL'
#'
#' @param session,input,output Shiny session objects shared between all modules.
#'
#' @return Displays list of ingredients to select. Adds the selected ingredients to the meal in progress..
#'
#' @noRd
addIngredientModal <- function(session,input,output,data){
ns <- session$ns
LOCAL <- data
showModal(
modalDialog(
fluidPage(
fluidRow(
column(width = 12,
h1(paste('Select Ingredients for',ifelse(LOCAL$editMode == FALSE,input$newmealinput,input$editmealname)))
),#end column
),#end fluidRow
fluidRow(
column(width = 12,
DTOutput(ns('ingredients'))
)#end column
)#end fluidRow
),#end fluidPage
title = 'Select Ingredients',
size = 'l',
easyClose = FALSE,
footer = tags$div(class = "btn_group",
btn_panelItem(ns('modalAddIngredient'),lbl='Add',icn = "plus", class = "btn-success"),
btn_panelItem(ns('modalCancel'),lbl='Cancel',icn = NULL, class = "btn-default"),
),#end div
)#end modalDialog
)#end showModal
LOCAL$li <- LOCAL$li %>% mutate(
INGREDIENT_CATEGORY = factor(INGREDIENT_CATEGORY, levels = unique(INGREDIENT_CATEGORY)),
INGREDIENT = factor(INGREDIENT, levels = unique(INGREDIENT))
)
}#end addIngredientModal
#'
#'
#'New meal modal
#' @description The modal displayed when committing a new meal. The user is asked to share with the database
#' or just use in this session
#'
#' @param session,input,output Shiny session objects shared between all modules.
#'
#' @return If share is selected, data are also written to the database. If not, they are written to the session only.
#'
#' @noRd
newMealModal <- function(session,input,output){
ns <- session$ns
showModal(
modalDialog(
'You created a new meal! Your new meal is now available to add via the Meal Type and Meal Name dropdowns.
\nWould you like to share this meal also to the public database?'
,#end message
title = 'New Meal Created',
size = 'm',
easyClose = FALSE,
footer = tags$div(class = "btn_group",
btn_panelItem(ns('modalCommitNewMeal'),lbl='Share',icn = "plus", class = "btn-success"),
btn_panelItem(ns('modalThisMenuOnly'),lbl='This Menu Only',icn = NULL, class = "btn-default"),
),#end div
)#end modalDialog
)#end showModal
}#end newMealModal
#'
#'New ingredient modal
#' @description The modal displayed when committing a new ingredient. The user is asked to share with the database
#' or just use in this session
#'
#' @param session,input,output Shiny session objects shared between all modules.
#'
#' @return If share is selected, data are also written to the database. If not, they are written to the session only.
#'
#' @noRd
newIngredientModal <- function(session,input,output){
ns <- session$ns
showModal(
modalDialog(
p('You created a new ingredient! Your new ingredient is now available to add to meals.'),
p('Would you like to share this ingredient also to the public database?')
,#end message
title = 'New Ingredient Created',
size = 'm',
easyClose = FALSE,
footer = tags$div(class = "btn_group",
btn_panelItem(ns('modalCommitNewIng'),lbl='Share',icn = "plus", class = "btn-success"),
btn_panelItem(ns('modalThisMenuOnly'),lbl='This Menu Only',icn = NULL, class = "btn-default"),
),#end div
)#end modalDialog
)#end showModal
}#end newIngredientModal
#'
#'Commit new ingredient
#' @description The modal displayed when commiting a new ingredient.
#'
#' @param data The reactive values list common to all modules, named 'LOCAL'
#'
#' @param session,input,output Shiny session objects shared between all modules.
#'
#' @return If share is selected, data are also written to the database. If not, they are written to the session only..
#'
#' @noRd
commitNewIngredient <- function(session,input,output,data){
ns <- session$ns
LOCAL <- data
LOCAL$li <- LOCAL$newIngredient %>%
select(names(LOCAL$li)) %>%
# mutate(
# SERVING_SIZE_FACTOR = as.numeric(SERVING_SIZE_FACTOR),
# INGREDIENT_ID = gsGetIDs()[[2]]#Getting latest next ingredient ID from DB
# ) %>%
bind_rows(LOCAL$li) %>%
mutate(
INGREDIENT_CATEGORY = factor(INGREDIENT_CATEGORY, levels = unique(INGREDIENT_CATEGORY)),
INGREDIENT = factor(INGREDIENT, levels = unique(INGREDIENT)),
STORAGE_DESCRIPTION = factor(STORAGE_DESCRIPTION, levels = unique(STORAGE_DESCRIPTION)),
)#end mutate
}#end commitNewIngredient
R Package Documentation
Browse R Packages
We want your feedback!
Note that we can't provide technical support on individual packages. You should contact the package authors for that.
Embedding an R snippet on your website
Add the following code to your website.
For more information on customizing the embed code, read Embedding Snippets.