Replace if with for loop does not work with data tables

shiny

#1

I have this code sample which works fine and produces 4 data tables

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
```{r}
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()

but when i replace if with for i do not take back data tables but i do not take an error as well.

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

DT::dataTableOutput("hist1") 
br()

Estimate from 01/05/2017

DT::dataTableOutput("hist2")
br()

Estimate from 12/03/2016

DT::dataTableOutput("hist3")
br()

Estimate from 11/09/2016

DT::dataTableOutput("hist4")
br()

#2

Can you put your latest attempt in a gist at gist.github.com? (I can see several problems but they’re hard to point out without line numbers) Thanks!


#3

i added it thanks.but can i send you somehow the dataset that i use?


#4

I also attach you the dataset that i use in my script in order to help you
reproduce the script. I assume this will help.
Makis


#5

I can make some comments even without the dataset. (Anyone else who’s following along, his gist is here)

  1. The observer on line 97 is unnecessary. Instead, the 5 lines of code inside the observer that assign a value to df, should be moved into the inside of output$hot's renderRHandsontable. Part 1 of my talk on “Effective Reactive Programming” covers why, you can jump to 16:00.
  2. You have two different for loops going on. One at line 151, which calls showHistory, which itself has a for loop at line 112. I’m not sure which one you want but I don’t think it’s both?
  3. The for loop at line 151 contains a reactive. It shouldn’t–this will cause that code to never run, since the reactives that you’re creating are never actually used anywhere. I highly recommend watching both parts of “Effective Reactive Programming”.
  4. It’s generally a bad idea in R to declare reactives, outputs, or closures inside of for loops. Instead, replace the for loop with an lapply. @barbara wrote up some examples here, see lines 95-98 that describe the root of the problem.
  5. Lines 157-166 seem a bit confused. What df is being modified in line 161? Why are the local variables df1 and df2 set to NULL and then never updated? Where do df3 and df4 come from?

#6

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()
})


#7

This is the dataset


#8

The dataset