r - input value by user to dataframe via shiny - r

I'm building an app that allows user to pass the value from selectizeInput or checkboxInput to form a dataframe. I've searched a while and found these sources that similar to what I expect:
handsontable
It is from here: https://github.com/jrowen/rhandsontable. Mine is quite similar to this exampe:
shiny::runGitHub("jrowen/rhandsontable",
subdir = "inst/examples/rhandsontable_portfolio")
But I want to use shiny widgets to pass values to the dataframe. It should be able to add/remove rows as following example:
shinyIncubator
code here:
library("shiny")
library('devtools')
install_github('shiny-incubator', 'rstudio')
library("shinyIncubator")
# initialize data with colnames
df <- data.frame(matrix(c("0","0"), 1, 2))
colnames(df) <- c("Input1", "Input2")
server = shinyServer(
function(input, output) {
# table of outputs
output$table.output <- renderTable(
{ res <- matrix(apply(input$data,1,prod))
res <- do.call(cbind, list(input$data, res))
colnames(res) <- c("Input 1","Input 2","Product")
res
}
, include.rownames = FALSE
, include.colnames = TRUE
, align = "cccc"
, digits = 2
, sanitize.text.function = function(x) x
)
}
)
ui = shinyUI(
pageWithSidebar(
headerPanel('Simple matrixInput example')
,
sidebarPanel(
# customize display settings
tags$head(
tags$style(type='text/css'
, "table.data { width: 300px; }"
, ".well {width: 80%; background-color: NULL; border: 0px solid rgb(255, 255, 255); box-shadow: 0px 0px 0px rgb(255, 255, 255) inset;}"
, ".tableinput .hide {display: table-header-group; color: black; align-items: center; text-align: center; align-self: center;}"
, ".tableinput-container {width: 100%; text-align: center;}"
, ".tableinput-buttons {margin: 10px;}"
, ".data {background-color: rgb(255,255,255);}"
, ".table th, .table td {text-align: center;}"
)
)
,
wellPanel(
h4("Input Table")
,
matrixInput(inputId = 'data', label = 'Add/Remove Rows', data = df)
,
helpText("This table accepts user input into each cell. The number of rows may be controlled by pressing the +/- buttons.")
)
)
,
mainPanel(
wellPanel(
wellPanel(
h4("Output Table")
,
tableOutput(outputId = 'table.output')
,
helpText("This table displays the input matrix together with the product of the rows of the input matrix")
)
)
)
)
)
runApp(list(ui = ui, server = server))
The value should be entered by user from shiny widgets such as selectizeInput, checkboxInput or textInput and passed to the dataframe once the user click my actionButton. What I want is pretty similar to the combination of the above functions but I don't know how to do. Any suggestions?
Many thanks in advance.

Though I ended up using none of the two packages, this worked fine:
library(shiny)
server = shinyServer(function(input, output, session){
values <- reactiveValues()
values$DT <- data.frame(Name = NA,
status = NA,
compare = NA,
stringsAsFactors = FALSE)
newEntry <- observeEvent(input$addrow, {
newLine <- c(input$textIn, input$boxIn, input$selectIn)
values$DT <- rbind(values$DT, newLine)
})
newEntry <- observeEvent(input$revrow, {
deleteLine <- values$DT[-nrow(values$DT), ]
values$DT <- deleteLine
})
output$table <- renderTable({
values$DT
})
})
ui = shinyUI(navbarPage(
"Backtest System", inverse = TRUE, id = "navbar",
tabPanel("Strategy",
sidebarLayout(
sidebarPanel(
h4("Indicator"),
textInput("textIn", "Text", "try"),
checkboxInput("boxIn", "Box", TRUE),
selectizeInput("selectIn", "Select",
choices = c(">" = ">",
">=" = ">=",
"<" = "<",
"<=" = "<=")),
actionButton("addrow", "Add Row"),
actionButton("revrow", "Remove Row")
),
mainPanel(
tableOutput("table")
)
)
)
)
)
runApp(list(ui = ui, server = server))

Related

In R Shiny, how to eliminate the flashing of observeEvent conditionals when first invoking the App?

In the below MWE code, the object input2 is optionally called by the user by clicking the "Show" radio button for Input 2. Default setting is to hide input2. However, when first invoking the App, input2 quickly flashes by before being hidden by the observeEvent.
This flashing is much more pronounced in the non-MWE version of the code.
There is a related post In R shiny, how to eliminate flashing of all conditional panels in sidebar when first invoking the App without using renderUI? that addresses this issue for conditionalPanel. But here there is no conditionalPanel.
I do not want to use renderUI to resolve this issue!! As renderUI has drawbacks I don't want to re-introduce.
MWE code:
library(shiny)
library(shinyjs)
f <- function(action,i){as.character(checkboxInput(paste0(action,i),label=NULL))}
actions <- c("show", "reset")
tbl <- t(outer(actions, c(1,2), FUN = Vectorize(f)))
colnames(tbl) <- c("Show", "Reset")
rownames(tbl) <- c("Input 2", "Input 3")
ui <- fluidPage(
useShinyjs(),
tags$head(
tags$style(HTML(
"td .checkbox {margin-top: 0; margin-bottom: 0;}
td .form-group {margin-bottom: 0;}"
))
),
br(),
sidebarLayout(
sidebarPanel(
numericInput("input1", "Input 1:", 10, min = 1, max = 100),
h5(strong("Add inputs:")),
tableOutput("checkboxes"),
numericInput("input2", "Input 2:", 10, min = 1, max = 100),
),
mainPanel()
)
)
server <- function(input, output, session){
output[["checkboxes"]] <-
renderTable({tbl},
rownames = TRUE, align = "c",
sanitize.text.function = function(x) x
)
observeEvent(input[["show1"]], {
if(input[["show1"]] %% 2 == 1){shinyjs::show(id = "input2")} else
{shinyjs::hide(id = "input2")}
})
}
shinyApp(ui, server)
It takes some time in the event loop until observerEvent is called the first time.
By default, it will be displayed at the very beginning.
This results into a flash.
Just hide input2 at the very beginning of the server function:
server <- function(input, output, session) {
# Avoid flashing
shinyjs::hide(id = "input2")
output[["checkboxes"]] <-
renderTable(
{
tbl
},
rownames = TRUE,
align = "c",
sanitize.text.function = function(x) x
)
observeEvent(input[["show1"]], {
if (input[["show1"]] %% 2 == 1) {
shinyjs::show(id = "input2")
} else {
shinyjs::hide(id = "input2")
}
})
}
You can also use hidden
hidden(numericInput("input2", "Input 2:", 10, min = 1, max = 100))
and toggle:
observeEvent(input[["show1"]], {
toggle("input2")
},ignoreNULL = FALSE)

How to store text input in a vector to be used later with R shiny?

I want to define two variables ("tickers" and "SharesVec") as empty vectors and add text inputs and numerical inputs (respectively) to these vectors when the button "action" is triggered. I will be using these vectors later to run a function. I'm not sure I understand how to use variables properly in R shiny (beginner). Here is what I tried so far:
UI
shinyUI(fluidPage(
titlePanel("Portfolio Analysis Tool"),
br(),
sidebarLayout(
sidebarPanel(
selectInput(
inputId = "DateFrom",
label = "Starting Year (YYYY-01-01)",
choices = format(Sys.Date(), "%Y"):1975
),
selectInput(
inputId = "DateTo",
label = "Ending Year (YYYY-12-31)",
choices = format(Sys.Date(), "%Y"):1975
),
h2("Initial Portfolio"),
p("Include every ticker owned at some point during the period (Number of shares = 0 if none are held at the starting date)", style = "font-size: 12px"),
textInput("Stock","Ticker"),
numericInput("Shares","Number of Shares",0, min = 0, step = 0.5),
column(12,
splitLayout(cellWidths = c("58%", "58%"),
actionButton("action", "Add",icon("dollar-sign"),
style="color: #fff; background-color: #337ab7; border-color: #2e6da4"),
actionButton("action1", "Reset",icon("trash"),
style="color: #fff; background-color: #337ab7; border-color: #2e6da4"))),
br(),
br(),
h2("Rebalancing"),
dateInput("DateReb", "Date of Purchase/Sale"),
textInput("Stock1", "Ticker"),
numericInput("Shares1","Number of Shares (+/-)", 0, step = 0.5),
column(12,
splitLayout(cellWidths = c("58%", "58%"),
actionButton("action2", "Add",icon("dollar-sign"),
style="color: #fff; background-color: #337ab7; border-color: #2e6da4"),
actionButton("action3", "Reset",icon("trash"),
style="color: #fff; background-color: #337ab7; border-color: #2e6da4"))),
br(),
br(),
),
mainPanel(
column(10,
splitLayout(cellWidths = c("50%", "50%"),
htmlOutput("InitialHoldings", style = "font-weight: bold; text-decoration: underline"),
htmlOutput("Rebalancing", style = "font-weight: bold; text-decoration: underline"))),
br(),
br(),
column(12,
tableOutput("table"),
style = "height:340px; overflow-y: scroll; border: 1px solid #e3e3e3; border-radius: 8px; background-color: #f7f7f7;text-align: left"),
textOutput("TEST")
)
)
))
Server
library(quantmod)
library(PerformanceAnalytics)
tickers <- c()
SharesVec <- c()
shinyServer(function(input, output) {
output$InitialHoldings <- renderText({paste("Initial Holdings")})
output$Rebalancing <- renderText({paste("Rebalancing")})
#Store Initial Stocks/Nb of Shares from User Inputs
values <- reactiveValues()
values$df <- data.frame("Stock" = numeric(0), "Shares" = numeric(0))
newEntry <- observe({
if(input$action > 0) {
isolate(values$df[nrow(values$df) + 1,] <- c(input$Stock, input$Shares))
tickers <- c(tickers,input$Stock)
SharesVec <- c(SharesVec,input$Shares)
}
})
output$table <- renderTable({values$df})
output$TEST <- renderText({paste(tickers)})
})
Note: I have included output$TEST in the code to see if the vector "tickers" updates itself properly. Also, I want to point out that since I added the lines
tickers <- c(tickers,input$Stock)
SharesVec <- c(SharesVec,input$Shares)
in the server, the action button doesn't work properly (it's no longer needed to add data to my table). I have also tried using global variables ->> but it didn't seem to work.. Could anyone help me?
Store the vectors in reactiveValues. You can change the server function to :
library(shiny)
shinyServer(function(input, output) {
output$InitialHoldings <- renderText({paste("Initial Holdings")})
output$Rebalancing <- renderText({paste("Rebalancing")})
#Store Initial Stocks/Nb of Shares from User Inputs
values <- reactiveValues(tickers = NULL, SharesVec = NULL)
observeEvent(input$action, {
values$tickers <- c(values$tickers,input$Stock)
values$SharesVec <- c(values$SharesVec,input$Shares)
})
output$TEST <- renderText({
paste(values$tickers, values$SharesVec, sep = ':', collapse = '\n')
})
}
Using output$TEST to show you the values that are stored.

ShinyApp Function not returning Result

I need help with the below shiny app server function. My problem is values$npv always comes out null, not even with a 0. and I think the fun function is not doing the right thing and i'm out of ideas.
If I hard-code the renderText with paste("Net Present Value:", isolate(input$val_inv)) i always have a result but not what i want and this makes me guess the fun function is not working as it should.
inline_numericInput=function(ni){
tags$div( class="form-inline",ni)
}
ui <- shinyUI(fluidPage(
tags$head(tags$style("#side_panel{
padding-left:10px;
}
.form-group {
margin-bottom: 15px !important;
}
.form-inline .form-control {
width:80%;
}
label{ width:30px;}
")),
titlePanel("Example"),
sidebarLayout(
sidebarPanel(width = 4,id="side_panel",
fluidRow(
column(6, inline_numericInput(numericInput("val_inv", label = "Inv:", value = 0))),
),
fluidRow(
column(6, inline_numericInput(numericInput("val_r", label = "R:", value = 0))),
),
fluidRow(
column(6, inline_numericInput(numericInput("val_n", label = "N:", min = 50,value = 50))),
column(6, inline_numericInput(actionButton("btn_calcnpv", label = "Compute NPV")))
)
),
mainPanel(
p('Results:'),
textOutput("val_npv")
)
)
))
server <- function(input, output) {
values <- reactiveValues()
values$npv <- 0
observe({
input$btn_calcnpv
fun <- function(n){
cf <- 0
for (i in 1:n){
cf <- cf + isolate(input$val_inv)/(1+input$var_r)**i
}
cf
}
values$npv <- fun(isolate(input$val_n))- isolate(input$val_inv)
#values$npv <- values$npv - isolate(input$val_inv)
})
output$val_npv <- renderText({
if(input$btn_calcnpv)
paste("Net Present Value:", values$npv)
else ""
})
}
shinyApp(ui, server)
Here is an answer using eventReactive and not so many isolations.
Furthermore, the inputs are coerced to numbers before the calculation takes place.
Using eventReactive, the calculation is started by pressing the compute-button.
server <- function(input, output) {
npv <- eventReactive(input$btn_calcnpv, {
val_inv <- as.numeric(input$val_inv)
val_r <- as.numeric(input$val_r)
val_n <- as.numeric(input$val_n)
fun <- function(n){
cf <- 0
for (i in 1:n){
cf <- cf + val_inv/(1+val_r)**i
}
cf
}
temp <- fun(val_n)- val_inv
temp
})
output$val_npv <- renderText({
req(npv())
paste("Net Present Value:", npv())
})
}

Rearange list of shiny wellpanels in R with uiOutput (shinyjqui)

I have a shiny app with list of wellPanels. They are used in jqui_sortable from shinyjqui. Panels are generated in server part (to uiOutput in ui). Order of panels can be changed by mouse and is written to file (by ids). Then I would like to open this file and change default order with loaded data.
Issue: I can't get out of rendered words "div" between panels (run code below).
Code was written with some lines from solution (thanks to #TimTeaFan):
Distorted spacing between div elements after sorting with jqui_sortable
library(shiny)
library(shinyjqui)
ui <- fluidPage(
sidebarLayout(fluid = TRUE,
sidebarPanel(helpText("HelpText")),
mainPanel(
fluidRow(column(12,
actionButton(inputId = "btn1",label = "Button1"),
tags$style(HTML(".ui-sortable {
width: 1200px !important;
} ")),
uiOutput('multiobject'),
actionButton(inputId = "btn2",label = "Button2")
))
)
)
)
server <- function(input, output, session) {
sortableorderednameList<-reactiveVal(
c("A","B","C")
)
wpFunc <- function(v,name,helptext){
return(tags$div(wellPanel(id=paste0(v,"P"),
div(style="display: inline-block; width: 10px;",
checkboxInput(paste0(v,"Chk"), label = NULL, value = TRUE)),
div(style="display: inline-block; width: 150px;",
textInput(paste0(v,"TI"), label = NULL, value = name)),
div(style="display: inline-block;",helpText(helptext)),
style = "padding: 1px;")))
}
observe({
if(is.null(input$sortablecollistJQ_order$id)) {return()}
mylist <- input$sortablecollistJQ_order$id
mylist <- unlist(lapply(mylist, function(v) substr(v,1,nchar(v)-1)))
print(mylist)
print(" ")
isolate(sortableorderednameList(mylist))
})
output$multiobject <- renderUI({
uiList <- list()
for (v in sortableorderednameList()) {
switch(v,
"A" = {uiList <- append(uiList,wpFunc(v,"A","There is A"))},
"B" = {uiList <- append(uiList,wpFunc(v,"B","There is B"))},
"C" = {uiList <- append(uiList,wpFunc(v,"C","There is C"))}
)
}
jqui_sortable(div(id = 'sortablecollistJQ',uiList))
})
}
shinyApp(ui, server)
I have got an answer after experiments. If somebody is interested.
for (i in 1:length(uiList)) {
uiList[i] <- uiList[i]$children
}
It changes structure of list, put it before jqui_sortable call.

Shiny with DT Select rows, keep cell color

I have a DT datatable that has cells colored according to a different variable. When you click on a row, it highlights values in a corresponding plot, exactly like in the example here. However, when you select a row, the new color that highlights the row overrides my existing colors. I'd like for the row to be highlighted, but the individual cell to maintain its color if it was already colored.
The screenshots below show what I'm getting and what I want. I modified Yihui's code to make a reproducible example below the screenshots. Any help would be appreciated!
library(shiny)
library(DT)
ui <- fluidPage(
title = 'Select Table Rows',
fluidRow(
column(6, DT::dataTableOutput('x1')),
column(6, plotOutput('x2', height = 500))
)
)
server <- function(input, output) {
cars <- cars %>%
mutate(low_speed = ifelse(speed < 5, 1, 0))
output$x1 <- renderDataTable({
datatable(cars,
options = list(columnDefs = list(list(targets = 3,
visible = FALSE)))) %>%
formatStyle("speed", "low_speed",
backgroundColor = styleEqual(c(0, 1),
c("transparent", "#E34755")))
})
# highlight selected rows in the scatterplot
output$x2 <- renderPlot({
s <- input$x1_rows_selected
par(mar = c(4, 4, 1, .1))
plot(cars[ ,-3])
if (length(s)) points(cars[s, , drop = FALSE], pch = 19, cex = 2)
})
}
shinyApp(ui, server)
You can define a CSS class for the background color (red below) and add it to the desired cells with a rowCallback. Then add this CSS:
.red {
background-color: #e34755;
}
table.dataTable tr.selected td.red {
background-color: #e34755 !important;
}
The app:
library(shiny)
library(DT)
rowCallback <- c(
"function(row, dat, displayNum, index){",
" if(dat[1] < 5){",
" $('td:eq(1)', row).addClass('red');",
" }",
"}"
)
css <- "
.red {
background-color: #e34755;
}
table.dataTable tr.selected td.red {
background-color: #e34755 !important;
}
"
ui <- fluidPage(
tags$head(
tags$style(HTML(css))
),
title = 'Select Table Rows',
fluidRow(
column(6, DTOutput('x1')),
column(6, plotOutput('x2', height = 500))
)
)
server <- function(input, output) {
output$x1 <- renderDT({
datatable(cars,
options = list(
columnDefs = list(list(targets = 3,visible = FALSE)),
rowCallback = JS(rowCallback)
)
)
})
# highlight selected rows in the scatterplot
output$x2 <- renderPlot({
s <- input$x1_rows_selected
par(mar = c(4, 4, 1, .1))
plot(cars[ ,-3])
if (length(s)) points(cars[s, , drop = FALSE], pch = 19, cex = 2)
})
}
shinyApp(ui, server)
You can make this happen with some custom CSS. Add this code block to your fluidPage:
tags$head(
tags$style(
HTML(
"table.dataTable tbody tr.selected td {
color: white !important;
background-color: #E34755 !important;}"
)
)
),
You could also drop that CSS snippet into a standalone file and place it in the www directory alongside your app file(s). See here for more Shiny CSS info.
Live Demo

Resources