I also attach the working example with if statements to give a better understanding
runtime: shiny
output:
flexdashboard::flex_dashboard:
theme: cosmo
orientation: rows
h1, h2, h3, h4, h5, h6, .h1, .h2, .h3, .h4, .h5, .h6, chart-title, .chart-title {
font-weight: bold;
}
.dataTables_filter {
display: none;
}
.btn-default {
color: #ffffff;
background-color: #1a6ecc;
border-color: #1a6ecc;
}
# FIXME: get themeSelector() working
# shinyApp(ui = fluidPage(shinythemes::themeSelector()), server = function(a, b) {})
# shinythemes::themeSelector()
library(rhandsontable)
library(magrittr)
library(DT)
library(data.table)
library(kableExtra)
library(shinyBS)
#library(shinyjs)
ROOT <- file.path('..', '..', '..')
title: "r paste("Estimates Portal", isolate(input$company), sep=' ')"
My Estimates {data-icon="fa-history"}
Estimates {.sidebar data-width=450}
Your current Estimate for 3/7/2017
br()
#measure_list <- sqlQuery(aidb_conn, "SELECT measure_name from measures_alpha ORDER BY measure_id ASC", stringsAsFactors = F)
measure_list <- c('Revenue Growth', 'Change in Gross Margin', 'Change in Operating Margin')
N_MEASURES <- length(measure_list)
# Form the template blank DF dynamically based on the measures available
DF = data.frame(
Variables = measure_list,
Lower.Bound = rep('', N_MEASURES),
Upper.Bound = rep('', N_MEASURES),
row.names = NULL,
stringsAsFactors = FALSE
)
load_history <- function(expert_nick_arg, company_arg) {
# cat(file=stderr(), "company_arg=", company_arg,"\n")
# cat(file=stderr(), "expert_nick_arg=", expert_nick_arg,"\n")
load("get_history_results.rda")
temp2 <- copy(temp); temp2$est_id <- temp2$est_id + 1
temp <- rbind(temp, temp2)
return(temp)
# query <- readLines("sql/estimates_query.sql")
# query2 <- paste(query, collapse='\n')
# query2 <- sub("NICK_PLACEHOLDER", expert_nick_arg, query2)
# query2 <- sub("TICKER_PLACEHOLDER", company_arg, query2)
# # cat(file=stderr(), "query2=", query2,"\n")
#
# est <- sqlQuery(aidb_conn, query2)
#
# return(est)
}
# What is est_reactive? est_reactive$est_new_df = data.frame with Estimate values from the rhandsontable in the LHS pane. est_reactive$clicks = 0 => show blank table in the LHS pane, 1 => show real values from est_reactive$est_new_df, est_reactive$already_submitted = to prevent re-submission
est_reactive <- reactiveValues(est_new_df = data.frame(), clicks=0, already_submitted=F)
rHandsontableOutput("hot")
observe({
# Show blank template initially
if (est_reactive$clicks == 0) {
df <- DF
} else {
df <- est_reactive$est_new_df
}
output$hot <- renderRHandsontable({
rhandsontable(df, width = 600, height = 150, selectCallback = TRUE, readOnly = T, contextMenu = F, fillHandle = F)
#runjs("HTMLWidgets.getInstance(output$hot).hot.selectCell(0,1);")
})
})
showHistory <- function(DF2, DF3, DF4, DF5) {
if (!is.null(DF2) && nrow(DF2) != 0) {
output$hist1 <- renderDataTable({DF2},
selection="none", options=list(paging=F, ordering=F,
searching=F, bLengthChange=F,
bFilter=F,bInfo=F)
)
}
if(!is.null(DF3) && nrow(DF3)!=0) {
output$hist2 <- renderDataTable({DF3},
selection="none", options=list(paging=F, ordering=F,
searching=F, bLengthChange=F,
bFilter=F,bInfo=F)
)
}
if(!is.null(DF4) && nrow(DF4)!=0) {
output$hist3 <- renderDataTable({DF4},
selection="none", options=list(paging=F, ordering=F,
searching=F, bLengthChange=F,
bFilter=F,bInfo=F)
)
}
if(!is.null(DF5) && nrow(DF5)!=0) {
output$hist4 <- renderDataTable({DF5},
selection="none", options=list(paging=F, ordering=F,
searching=F, bLengthChange=F,
bFilter=F,bInfo=F)
)
}
} # end of showHistory()
# Get est history from the DB
#est <- reactive({load_history('Bill Nye', 'ai001161.01')})
est <- reactive({load_history(input$expert, input$company)})
est_list <- reactive({
est2 <- est()
#cat("class(est2)=", class(est2), "\n")
#cat("dim(est2)=", dim(est2), "\n")
#print(est2)
split(est2, est2$est_id)
})
# Dummy hist for testing
#df1 <- make_history()
#df2 <- make_history()
#df_list <- list(df1, df2)
get_measure_columns <- function(df) {
df2 <- df[, c('measure_name', 'value_lower', 'value_upper')]
colnames(df2) <- c('Variable', 'Lower Bound', 'Upper Bound')
df2
}
reactive({
el <- est_list()
#cat("el=\n")
#print(el)
df1 <- NULL
df2 <- NULL
if (length(el) >= 1) {
df1 <- get_measure_columns(el[[1]])
}
if (length(el) >= 2) {
df2 <- get_measure_columns(el[[2]])
}
if (length(el) >= 3) {
df3 <- get_measure_columns(el[[3]])
}
if (length(el) >=4) {
df4 <- get_measure_columns(el[[4]])
}
showHistory(df1, df2, df3, df4)
})
Your past Estimates
Estimate from 02/07/2017
dataTableOutput("hist1")
br()
Estimate from 01/05/2017
dataTableOutput("hist2")
br()
Estimate from 12/03/2016
dataTableOutput("hist3")
br()
Estimate from 11/09/2016
dataTableOutput("hist4")
br()
Input {data-height=150}
Input
renderUI({
tagList(
tags$br(),
if (est_reactive$already_submitted)
tags$br()
else if(is.null(input$hot_select)) {
tags$b("Please click on the cell you would like to change in the Current Estimates table")
} else {
# #learning #vv : both bold and underling using shiny::tags(), list() inside tags$b(), plus using tagList() in renderUI() to output HTML
tags$b(list("Please provide the",
tags$u(colnames(DF)[input$hot_select$select$c]),
"for your 80% confidence interval for",
tags$u(DF[input$hot_select$select$r,1]),
"over the next 12 months for", input$company, sep="\n"))
}
) # end of tagList()
})
Row {data-height=850}
numeric_input <- reactiveValues(box=0)
observeEvent(input$hot_select, {
if (!is.null(est_reactive$est_new_df[input$hot_select$select$r, input$hot_select$select$c])) {
get_value <- function(row,col) {
val <- as.c(est_reactive$est_new_df[row,col])
return(strsplit(val, "%")[[1]])
}
updateTextInput(session, "box", value=get_value(input$hot_select$select$r,input$hot_select$select$c))
}
})
observeEvent(input$click, {
if(!is.null(input$box)) {
if(try(!is.na(as.numeric(input$box)))) {
# VV: 20171030: use as.numeric() to convert "45.", which is a valid R number, to 45.0
numeric_input$box <- as.numeric(input$box)
} else {
showModal(modalDialog(title = "Error", "Please provide only numeric values as estimate"))
numeric_input$box <- NA
}
}
})
observe({
if(!is.null(input$hot)) {
est_reactive$est_new_df <- hot_to_r(input$hot)
}
})
observeEvent(input$click, {
if(!is.null(input$box)) {
if (!is.null(input$hot_select)) {
col <- input$hot_select$select$c
row <- input$hot_select$select$r
if (row == 1) {
est_reactive$est_new_df[row, col] <- paste0(numeric_input$box, "%")
} else {
est_reactive$est_new_df[row, col] <- numeric_input$box
}
est_reactive$clicks <- est_reactive$clicks + 1
} else {
showModal(modalDialog(title = "Error", "Please select a cell in the Current Estimates table before submitting an Estimate"))
}
} # if !is.null(input$box0)
})
DONE_TEXT <- "Estimates submitted. Thank you!"
textOutput("already_submitted2")
output$already_submitted2 <- renderText({
#cat("est_reactive$already_submitted=", est_reactive$already_submitted)
if (est_reactive$already_submitted) {
return(DONE_TEXT)
} else {
return("")
}
})
conditionalPanel(condition=paste0("output.already_submitted2 != '", DONE_TEXT, "'"),
fluidRow(
column(width=4, style='padding-right:100px;',
textInput("box", label="",value=""),
br(),
br(),
actionButton("click","Enter estimate", width=160),
br(),
br(),
actionButton("submit","Submit a table", icon("paper-plane"), width=160)
),
column(width=8,
br(),
renderImage ({
list(src="wheel.png", width=350)
}, deleteFile = FALSE)
)
)
)
# "Are you sure you want to submit?"-related callbacks
observeEvent(input$submit, {
if(est_reactive$already_submitted == F) {
showModal(modalDialog(title = "Confirm", "Are you sure you want to submit these values?", easyClose=T,
footer=tagList(actionButton("Butyes", "Yes"), actionButton("Butno", "No"))
))
} else {
showModal(modalDialog(title = "Error", "Sorry, you have already submitted a table during this session! Please reload if you would like to re-submit a new set of Estimates", easyClose=T))
}
})
renderRHandsontableWithCustomFormatting <- function() {
# Render current estimates table with pink background
df <- est_reactive$est_new_df
output$hot <- renderRHandsontable({
rhandsontable(df, width = 600, height = 150, selectCallback = TRUE, readOnly = T, contextMenu = F, fillHandle = F) %>%
hot_cols(renderer = "
function (instance, td, row, col, prop, value, cellProperties) {
td.style.background = 'lightgrey';
}")
})
}
# Upon confirmation, save est_new_df to DB
observeEvent(input$Butyes, {
removeModal()
# TODO: save est_new_df to DB
# sqlSave(, update=T)
est_reactive$already_submitted <- T
renderRHandsontableWithCustomFormatting()
showModal(modalDialog(title = "Done", "Thank you", easyClose=F))
})
observeEvent(input$Butno, {
removeModal()
})