Skip to content

Instantly share code, notes, and snippets.

@makis23
Last active November 3, 2017 01:32
Show Gist options
  • Save makis23/1aa239c4fda95d2b8c5083de9eeb8f4d to your computer and use it in GitHub Desktop.
Save makis23/1aa239c4fda95d2b8c5083de9eeb8f4d to your computer and use it in GitHub Desktop.
Replace if with for loop does not work with datatables
###DATASET: https://www.dropbox.com/s/fzys7g697j6mj8x/get_history_results.rda?dl=0
---
runtime: shiny
output:
flexdashboard::flex_dashboard:
theme: cosmo
orientation: rows
---
<style type="text/css">
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;
}
</style>
```{r}
# FIXME: get themeSelector() working
# shinyApp(ui = fluidPage(shinythemes::themeSelector()), server = function(a, b) {})
# shinythemes::themeSelector()
```
```{r}
library(rhandsontable)
library(magrittr)
library(DT)
library(data.table)
library(kableExtra)
library(shinyBS)
library(shiny)
#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
```{r}
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) {
for(i in 2:5){
if (!is.null(DF[i]) && nrow(DF[i]) != 0) {
output$hist[i-1] <- DT::renderDataTable({
DT:: datatable (DF[i],
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
}
for(i in 1:4){
reactive({
el <- est_list()
#cat("el=\n")
#print(el)
df1 <- NULL
df2 <- NULL
if (length(el) >= i) {
df[i] <- get_measure_columns(el[[i]])
}
showHistory(
df1,df2,df3,df4)
})}
```
#### Your past Estimates
Estimate from 02/07/2017
```{r}
DT::dataTableOutput("hist1")
br()
```
Estimate from 01/05/2017
```{r}
DT::dataTableOutput("hist2")
br()
```
Estimate from 12/03/2016
```{r}
DT::dataTableOutput("hist3")
br()
```
Estimate from 11/09/2016
```{r}
DT::dataTableOutput("hist4")
br()
```
Input {data-height=150}
-----------------------------------------------------------------------
#### Input
```{r}
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}
-----------------------------------------------------------------------
```{r}
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)
)
)
)
```
```{r}
# "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()
})
```
@makis23
Copy link
Author

makis23 commented Nov 3, 2017

i also attach the working example with if statements for better understanding the issue

runtime: shiny
output:
flexdashboard::flex_dashboard:
theme: cosmo
orientation: rows

<style type="text/css"> 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; } </style>
# 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()
})

@makis23
Copy link
Author

makis23 commented Nov 3, 2017

Sign up for free to join this conversation on GitHub. Already have an account? Sign in to comment