I have a question about Authentication. I would like to use the shinyauthr for Authentication for only one pages in Shiny App, such as security_selection menuItem in the code below.
I don't want to display the login-window in the Portfolio, so the APP can show the Portfolio menuItem without password.
Thanks for your help!
Hees
#####################################################################
#####################################################################
Example here.
UI
library(shiny)
library(shinyauthr)
library(shinyjs)
library(shinydashboard)
security_selection_ui <- tagList(selectInput("name", "Name", choice = "user1",
selected = "user1"),
selectInput("asset", "Asset", choice = c("Equity", "Debt", "Gold", "BTC"),
selected = "SPY"),
selectInput("action", "Action", choice = c("Buy", "Sell"), selected = "Buy"),
numericInput("quantity", "Assets to buy or sell", value = 100, min = 0,
max = 10e6),
actionButton("submit", "Submit")
)
portfolio_ui <- tabItem("portfolow", tags$p("THis is a note"))
user_base <- data.frame(
user = c("user1", "user2"),
password = c("pass1", "pass2"),
permissions = c("admin", "standard"),
name = c("User One", "User Two"),
stringsAsFactors = FALSE
)
ui <- dashboardPage(
dashboardHeader(title = "My Dashboard"),
dashboardSidebar(
shinyjs::useShinyjs(),
# add logout button UI
div(class = "pull-right", shinyauthr::logoutUI(id = "logout")),
sidebarMenu(
menuItem("Security Selection", tabName = "security_selection",
icon = icon("dashboard")),
menuItem("Portfolio", tabName = "portfolio", icon = icon("th"))
)),
dashboardBody(
useShinyjs(),
#tags$head(tags$style(".table{margin: 0 auto;}"),
# tags$script(src="https://cdnjs.cloudflare.com/ajax/libs/iframe-resizer/3.5.16/iframeResizer.contentWindow.min.js",
# type="text/javascript"),
# includeScript("returnClick.js")
#),
shinyauthr::loginUI("login"),
tabItems(
# first tab content
tabItem(tabName = "security_selection",
uiOutput("security_selection")),
tabItem(tabName = "portfolio", uiOutput("portfolio"))
)
)
)
Server
server <- function(input, output, session) {
# 1
credentials <- shinyauthr::loginServer("login",
data = user_base,
user_col = user,
pwd_col = password,
sodium_hashed = FALSE,
log_out = reactive(logout_init()))
# 2
logout_init <- shinyauthr::logoutServer("logout", active = reactive(credentials()$user_auth))
#user_info <- reactive({credentials()$info})
#user_data <- reactive({
# req(credentials()$user_auth)
output$security_selection <- renderUI({
req(credentials()$user_auth)
security_selection_ui
})
output$portfolio <- renderUI({
#req(credentials()$user_auth)
portfolio_ui
})
}
shiny::shinyApp(ui, server)
The simple example
#####################################################################
#####################################################################
Related
I have written a simple example of what I am doing. I have 3000 numbers that I want to show in a selectInput. The numbers have to be in a reactive function, since in my original work, the data is from a file.
My problem is that when I run the app it only appears 1000 numbers, not the entire data (3000 numbers).
I have seen this post Updating selection of server-side selectize input with >1000 choices fails but I don't know how can I do it using uiOutput and renderUI.
Can anyone help me?
Thanks very much in advance
The code:
library(shiny)
ui <- fluidPage(
titlePanel("Numbers"),
sidebarLayout(
sidebarPanel(
uiOutput('selectUI')
),
mainPanel(
)
)
)
server <- function(input, output) {
num <- reactive({
data = c(1:3000)
return(data)
})
output$selectUI <- renderUI({
selectInput(inputId = 'options', "Select one", choices = num())
})
}
# Run the application
shinyApp(ui = ui, server = server)
Use selectizeInput instead of selectInput with the argument options = list(maxOptions = 3000).
Thanks to Stéphane Laurent's answer, the example will be solved like this:
library(shiny)
ui <- fluidPage(
titlePanel("Numbers"),
sidebarLayout(
sidebarPanel(
selectizeInput(inputId = "options", label = "Select one", choices=character(0)),
),
mainPanel(
)
)
)
server <- function(input, output, session) {
num <- reactive({
data = c(1:3000)
return(data)
})
observe({
updateSelectizeInput(
session = session,
inputId = "options",
label = "Select one",
choices= num(), options=list(maxOptions = length(num())),
server = TRUE)
})
}
# Run the application
shinyApp(ui = ui, server = server)
This code will work if you have more than 3000 entries. It will show you ALL the choices that you have. However, if you have a long list of choices (e.g. 60000) it will decrease the speed of your app.
The following shiny app works the first time you run it, but then errors if you change the species input because the table name already exists in memory. I was wondering how to set overwrite == TRUE given the code below?
library(shiny)
library(tidyverse)
library(dbplyr)
ui <- fluidPage(
selectInput("species", "Species", choices = unique(iris$Species),
selected = "setosa"),
tableOutput("SQL_table"),
actionButton("code", "View SQL"),
)
server <- function(input, output) {
# render table
output$SQL_table <- renderTable(
head(iris %>% filter(Species == input[["species"]]))
)
# generate query
SQLquery <- reactive({
sql_render(
show_query(
tbl_memdb(iris) %>%
filter(Species == local(input$species))
)
)
})
# see query
observeEvent( input$code, {
showModal(
modalDialog(
SQLquery()
)
)
})
}
shinyApp(ui = ui, server = server)
since memdb_frame is just a function call of copy_to we can use it directly to set overwrite = TRUE
copy_to(src_memdb(), iris, name = 'iris', overwrite=TRUE)
I am trying to insert tabs dynamically calling the insertTab() function within a module. For some reason my approach does not work. I guess the problem is how I pass the tabsetPanel id and the value of an existing tabPanel (next to which a tab should be added) to the module.
actionButUI = function(id, label=NULL) {
ns = NS(id)
tagList(
actionButton(ns("button"), label = label)
)
}
actionBut = function(input, output, session, tabsetPanel_id, target) {
observeEvent(input$button, {
insertTab(
inputId = tabsetPanel_id(),
tabPanel(
"Dynamic", "This a dynamically-added tab"
),
target = target
)
})
}
ui <- fluidPage(
sidebarLayout(
sidebarPanel(
actionButUI("append_tab", "Insert Tab")
),
mainPanel(
tabsetPanel(id = "tabs",
tabPanel("Hello", "This is the hello tab"),
tabPanel("Bar", "This is the bar tab")
)
)
)
)
server <- function(input, output, session) {
callModule(actionBut, "append_tab", reactive({input$tabs}), "Bar")
}
shinyApp(ui, server)
There seems to be an issue with namespaces. The followig modification fixes the issue
tabsetPanel(id = "append_tab-tabs",
tabPanel("Hello", "This is the hello tab"),
tabPanel("Bar", "This is the bar tab"))
The insertTab function tries to add a ui element in the module namespace rather than the global one. If you look at the source code of insertTab you'll see the line
inputId <- session$ns(inputId)
which causes this behavior.
Another way is to pass the session variable from the main app to insetTab rather than the module's session.
actionBut = function(input, output, session, tabsetPanel_id = "tabs", target) {
## do some environment hacking: Get the `session` variabe from the
## environment that invoked `callModule`.
parentSession <- get("session", envir = parent.frame(2))
observeEvent(input$button, {
insertTab(
inputId = tabsetPanel_id,
tabPanel(
"Dynamic", "This a dynamically-added tab"
),
target = target,
session = parentSession
)
})
}
This approach can get quite messy however if you work with nested modules.
An alternative to the InsertTab function, you can follow Ramnath solution here.
I have made it into modules.
library(shiny)
#---- Module Add dynamic tab ---
SidebarUi <- function(id) {
ns <- NS(id)
uiOutput(ns("sidebar"))
}
MainpanelUi <- function(id) {
ns <- NS(id)
uiOutput(ns("mainpanel"))
}
DynamicTabserver <- function(input, output, session) {
ns <- session$ns
output$sidebar <- renderUI({
actionButton(ns("nTabs"), label = "Add tab")
})
output$mainpanel <- renderUI({
uiOutput(ns('mytabs'))
})
output$mytabs <- renderUI({
nTabs = input$nTabs
myTabs = lapply(paste('Tab', 0:nTabs), tabPanel)
do.call(tabsetPanel, myTabs)
})
}
#---- App.R ---
ui = pageWithSidebar(headerPanel('Dynamic Tabs'),
sidebarPanel(SidebarUi("tabdemo")),
mainPanel(MainpanelUi("tabdemo")))
server = function(input, output, session) {
callModule(DynamicTabserver, "tabdemo")
}
shinyApp(ui, server)
I've been scratching my head trying to figure this out.
So I've connected to the database but when I press the action button nothing is happening to the table.
The CSV is being converted to a data frame.
UI
library(shiny)
library(RJDBC)
library(dbtools)
library(jsonlite)
library(shinyjs)
library(DBI)
# App title ----
titlePanel("Uploading Files"),
# Sidebar layout with input and output definitions ----
sidebarLayout(
# Sidebar panel for inputs ----
sidebarPanel(
# Input: Select a file ----
fileInput("file1", "Choose CSV File",
multiple = TRUE,
accept = c("text/csv",
"text/comma-separated-values,text/plain",
".csv")),
tags$head(
tags$style(HTML(
'#Uploadbutton{background-color:cyan}'
))
),
actionButton("Uploadbutton","Upload"),
p("Upload Members if data looks ok")
),
# Main panel for displaying outputs ----
mainPanel(
# Output: Data file ----
tableOutput("contents")
)
)
)
Server
server <- function(input, output) {
output$contents <- renderTable({
# input$file1 will be NULL initially. After the user selects
# and uploads a file, head of that data file by default,
# or all rows if selected, will be shown.
req(input$file1)
data <- read.csv(input$file1$datapath,header=TRUE)
if(input$disp == "head") {
return(head(data))
}
else {
return(data)
}
data <- data.frame()
data <<- read.csv(input$file1$datapath,header=TRUE)
testdata <- read.csv("data",sep=",",row.names=1)
observeEvent(input$Uploadbutton, {
insert_into("data", "ANALYTICS.TEST_DATASTORE", con=lol, rows_per_statement=1)
})
}
)
Hi I think what you are looking for is something like
DBI::dbWriteTable(con=lol, name = "ANALYTICS.TEST_DATASTORE",value = dta(),append = TRUE)
also I would structure the server function a bit different so that we don't need to use global variables
server <- function(input, output) {
dta <- reactive({
# input$file1 will be NULL initially. After the user selects
# and uploads a file, head of that data file by default,
# or all rows if selected, will be shown.
req(input$file1)
data <- read.csv(input$file1$datapath,header=TRUE)
if(input$disp == "head") {
return(head(data))
}
else {
return(data)
}
})
output$contents <- renderTable({
dta()
})
observeEvent(input$Uploadbutton, {
DBI::dbWriteTable(con=lol, name = "ANALYTICS.TEST_DATASTORE",value = dta(),append = TRUE)
})
}
Hope this helps!
This will upload the file for you. Then, send the data to SQL Server.
library(shiny)
# Define UI for data upload app ----
ui <- fluidPage(
# App title ----
titlePanel("Uploading Files"),
# Sidebar layout with input and output definitions ----
sidebarLayout(
# Sidebar panel for inputs ----
sidebarPanel(
# Input: Select a file ----
fileInput("file1", "Choose CSV File",
multiple = TRUE,
accept = c("text/csv",
"text/comma-separated-values,text/plain",
".csv")),
# Horizontal line ----
tags$hr(),
# Input: Checkbox if file has header ----
checkboxInput("header", "Header", TRUE),
# Input: Select separator ----
radioButtons("sep", "Separator",
choices = c(Comma = ",",
Semicolon = ";",
Tab = "\t"),
selected = ","),
# Input: Select quotes ----
radioButtons("quote", "Quote",
choices = c(None = "",
"Double Quote" = '"',
"Single Quote" = "'"),
selected = '"'),
# Horizontal line ----
tags$hr(),
# Input: Select number of rows to display ----
radioButtons("disp", "Display",
choices = c(Head = "head",
All = "all"),
selected = "head")
),
# Main panel for displaying outputs ----
mainPanel(
# Output: Data file ----
tableOutput("contents")
)
)
)
# Define server logic to read selected file ----
server <- function(input, output) {
output$contents <- renderTable({
# input$file1 will be NULL initially. After the user selects
# and uploads a file, head of that data file by default,
# or all rows if selected, will be shown.
req(input$file1)
df <- read.csv(input$file1$datapath,
header = input$header,
sep = input$sep,
quote = input$quote)
if(input$disp == "head") {
return(head(df))
}
else {
return(df)
}
})
}
# Run the app ----
shinyApp(ui, server)
Thanks for all the help guys figured out how to do it this was the server side.
server <- function(input, output, session) {
output$contents <- DT::renderDataTable({
# input$file1 will be NULL initially. After the user selects
# and uploads a file, head of that data file by default,
# or all rows if selected, will be shown.
req(input$file1)
data <- read.csv(input$file1$datapath,header=TRUE)
return(data)
})
observeEvent(input$Uploadbutton,
{insert_into(read.csv(input$file1$datapath),"ANALYTICS.TEST_DATASTORE")},once=TRUE
)
}
The following code (within my shiny app) is giving me this error:
"You have an error in your SQL syntax; check the manual that corresponds to your MySQL server version for the right syntax to use near '' at line 1"
shinyServer(function(input, output, session) {
dataTable <- reactive ({
data <- input$dataset
con <-
dbConnect(
drv = dbDriver("MySQL"),
dbname = "Database",
host = 'remote',
port = 3306,
user = "user",
password = "password")
on.exit(dbDisconnect(con))
dbGetQuery(con, paste("select * from ", data, ";"))
})
output$myTable <- renderDataTable({
datatable(dataTable(),
rownames = FALSE,
filter = "top",
extensions = 'Buttons',
options = list(dom = 'Bfrtip', buttons = I('colvis')))
})
})
shinyUI(fluidPage(
titlePanel("Data Search"),
# SidePanel -------------------------------------------
# -The Input/Dropdown Menu that Control the Output
sidebarLayout(
sidebarPanel(
selectInput(
inputId = "dataset",
label = "Select Dataset",
choices = c("", "Schools", "GradRates"),
selected = "",
multiple = FALSE),
width = 3
),
# MainPanel -------------------------------------------
# -The Output/Table Displayed Based on Input
mainPanel(
dataTableOutput(outputId = "myTable"),
width = 9
)
))
You have most likely problem with this line
dbGetQuery(con, paste("select * from ", data, ";"))
It appears that variable data doesn't contain table name as expected. Check your code where you are inserting table name into data.