I am using LDAvis in R shiny app.
Here is the code and it works without errors.
# docs is a csv file with a "text" column, e.g.
# docs <- read.csv("docs.csv",sep=",",header=TRUE)
ui <- navbarPage(
title = "NLP app",
tabPanel("Topic Model",icon = icon("group"),
fluidPage(
headerPanel(""),
titlePanel(p(h2("Topic Modelling example",style = "color:#4d3a7d"))),
#sidebarPanel(
wellPanel(tags$style(type="text/css", '#leftPanel { width:200px; float:left;}'), style = "background: lightgrey",
id = "leftPanel",
sliderInput("nTopics", "Number of topics to display", min = 5, max = 50, value = 10, step=5),
sliderInput("nTerms", "#top terms per topic", min = 10, max = 50, value = 20, step=5),
tags$hr(),
actionButton(inputId = "GoButton", label = "Go", icon("refresh"))
),
mainPanel(
tabPanel("Topic Visualisation", hr(),helpText(h2("Please select a topic!")), visOutput('visChart')))
)
)
)
# server
server <- function(input, output, session) {
Topic_Subset <- reactive({
docs <- docs$text
nTopics <- input$nTopics
# topic model using text2vec package
tokens = docs %>%
tolower %>%
word_tokenizer
it = itoken(tokens, progressbar = FALSE)
v = create_vocabulary(it,stopwords=tm::stopwords("en"))
vectorizer = vocab_vectorizer(v)
dtm = create_dtm(it, vectorizer, type = "dgTMatrix")
lda_model = text2vec::LDA$new(n_topics = nTopics, doc_topic_prior = 0.1, topic_word_prior = 0.01)
lda_model$fit_transform(x = dtm, n_iter = 1000,
convergence_tol = 0.001, n_check_convergence = 25,
progressbar = FALSE)
return(lda_model) #
})
output$visChart <- renderVis({
input$GoButton
isolate({
nterms <- input$nTerms
lda_model <- Topic_Subset()
})
lda_model$plot(out.dir = "./results", R = nterms, open.browser = FALSE)
readLines("./results/lda.json")
})
}
shinyApp(ui = ui, server = server)
I would like to see whether it is possible to use width = "80%" in visOutput('visChart') similar to, for example, wordcloud2Output("a_name",width = "80%"); or any alternative methods to make the size of visualization smaller. Particularly, when I minimize the shiny app window, the plot does not fit in the page. My second question is: how can I initialize the parameter lambda (please see the below image and yellow highlights) with another number like 0.6 (not 1)?
Related
Can I get help on how to get the below code to work? I am looking to update the numbers in
dataExample <- getDataset(n1 = c(20),n2 = c(20), means1 = c(18), means2 = c(9),stds1 = c(14), stds2 = c(14))
based on input values and then generate the plot whenever I apply changes but not sure how to do it. I read it somewhere it says need to use reactive or observe but I am not sure how to modify the code?
library(shiny)
library(plyr)
library(rmarkdown)
library(rpact)
design <- getDesignGroupSequential(kMax = 2, alpha = 0.05, informationRates = c(0.5, 1), typeOfDesign = "WT", deltaWT = 0.5)
ui <- fluidPage(
titlePanel("Efficacy Monitoring Using Conditional Power"),
sidebarLayout(
sidebarPanel(
numericInput('nn1', 'Number of Subjects at Current stage (Active)', 20, min = 1, max = 100),
numericInput('nn2', 'Number of Subjects at Current stage (Control)', 20, min = 1, max = 100),
textInput('Mean1', 'Mean1',"18"),
textInput('Mean2', 'Mean2',"9"),
textInput('SD1', 'SD1',"14"),
textInput('SD2', 'SD2',"14"),
textInput('nPlanned', 'Additional Numbers Planned',"40"),
submitButton(text = 'Apply Changes')
),
# Main panel for displaying outputs ----
mainPanel(plotOutput("plot2")
)
)
)
server <- function(input,output){
dataExample <- getDataset(
n1 = c(20),
n2 = c(20),
means1 = c(18),
means2 = c(9),
stds1 = c(14),
stds2 = c(14)
)
stageResults <- getStageResults(design, dataExample,thetaH0 = 0)
output$plot2<-renderPlot(
plot(stageResults, nPlanned = c(as.numeric(input$nPlanned)), thetaRange = c(0, 20))
)
}
# Run the app ----
shinyApp(ui, server)
Use a reactive function and put the input values
library(shiny)
library(plyr)
library(rmarkdown)
library(rpact)
design <- getDesignGroupSequential(kMax = 2, alpha = 0.05, informationRates = c(0.5, 1), typeOfDesign = "WT", deltaWT = 0.5)
ui <- fluidPage(
titlePanel("Efficacy Monitoring Using Conditional Power"),
sidebarLayout(
sidebarPanel(
numericInput('nn1', 'Number of Subjects at Current stage (Active)', 20, min = 1, max = 100),
numericInput('nn2', 'Number of Subjects at Current stage (Control)', 20, min = 1, max = 100),
# WHY THE CHOICE OF textInput instead of numericInput ?
textInput('Mean1', 'Mean1',"18"),
textInput('Mean2', 'Mean2',"9"),
textInput('SD1', 'SD1',"14"),
textInput('SD2', 'SD2',"14"),
textInput('nPlanned', 'Additional Numbers Planned',"40"),
submitButton(text = 'Apply Changes')
),
# Main panel for displaying outputs ----
mainPanel(plotOutput("plot2")
)
)
)
server <- function(input,output){
# Use the input values in a reactive function
dataExample <- reactive({
getDataset(
n1 = input$nn1,
n2 = input$nn2,
means1 = as.numeric(input$Mean1),
means2 = as.numeric(input$Mean2),
stds1 = as.numeric(input$SD1),
stds2 = as.numeric(input$SD2)
)
})
output$plot2<-renderPlot({
stageResults <- getStageResults(design, dataExample(), thetaH0 = 0)
plot(stageResults, nPlanned = c(as.numeric(input$nPlanned)), thetaRange = c(0, 20))
})
}
# Run the app ----
shinyApp(ui, server)
I have a R shinydashboard where a table can be edited and then I'd like the new table to be passed to the function agree() to calculate a statistic to be printed upon clicking an action button. I'm getting the following error in my renderPrint box on the app and assume a few things may be off in my code:
Error message in renderPrint box on app:
structure(function (...) ,{, if (length(outputArgs) != 0 && !hasExecuted$get()) {, warning("Unused argument: outputArgs. The argument outputArgs is only ", , "meant to be used when embedding snippets of Shiny code in an ", , "R Markdown code chunk (using runtime: shiny). When running a ", , "full Shiny app, please set the output arguments directly in ", , "the corresponding output function of your UI code."), hasExecuted$set(TRUE), }, if (is.null(formals(renderFunc))) , renderFunc(), else renderFunc(...),}, class = "function", outputFunc = function (outputId, placeholder = FALSE) ,{, pre(id = outputId, class = "shiny-text-output", class = if (!placeholder) , "noplaceholder"),}, outputArgs = list(), hasExecuted = <environment>, cacheHint = list(, label = "renderPrint", origUserExpr = agree(as.data.frame(table1))))
Below is my code (I have 3 tabItems but am just focusing on getting the first tab: tabName = "2int" to work. Issue lies in the sever code of output$irr1. Can use the baseR cor() function in replace of agree() from the irr package for testing purposes. Just need the updated table to be saved as a dataframe with all numbers or matrix to function correctly with the agree() function.
library(shiny)
library(irr)
library(DT)
library(dplyr)
library(shinydashboard)
ui <- dashboardPage(
dashboardHeader(title = "Interview Reliability"),
dashboardSidebar(
sidebarMenu(
menuItem("Two Interviewers",
tabName = "2int",
icon = icon("glass-whiskey")),
menuItem("Three Interviewers",
tabName = "3int",
icon = icon("glass-whiskey")),
menuItem("Four Interviewers",
tabName = "4int",
icon = icon("glass-whiskey"))
)
),
dashboardBody(
tabItems(
tabItem(tabName = "2int",
fluidRow(box(sliderInput("obs1", "Number of Interview Questions:",
value = 4,
min = 4,
max = 12,
step = 1))),
box(dataTableOutput("table1")),
box(verbatimTextOutput("irr1")),
box(actionButton("calc1", "Calculate"))
),
tabItem(tabName = "3int",
box(sliderInput("obs2", "Number of Interview Questions:",
value = 4,
min = 4,
max = 12,
step = 1))
),
tabItem(tabName = "4int",
box(sliderInput("obs3", "Number of Interview Questions:",
value = 4,
min = 4,
max = 12,
step = 1)),
)
)
)
)
server <- function(input, output) {
tablevalues <- reactiveValues(df = NULL)
observeEvent(input$obs1, {
tablevalues$df <- matrix(NA, nrow = input$obs1, ncol = 2,
dimnames = list(1:input$obs1, c("Interviewer 1", "Interviewer 2")))
})
output$table1 <- renderDT(tablevalues$df, escape = FALSE, selection = 'none', editable=TRUE)
output$irr1 <- eventReactive(input$calc1, {
renderPrint(agree(as.data.frame(table1)))
})
}
shinyApp(ui = ui, server = server)
You are mixing things here, and therefore your syntax is incorrect. Try this
server <- function(input, output) {
tablevalues <- reactiveValues(df = NULL)
observeEvent(input$obs1, {
tablevalues$df <- matrix(NA, nrow = input$obs1, ncol = 2,
dimnames = list(1:input$obs1, c("Interviewer 1", "Interviewer 2")))
})
output$table1 <- renderDT(tablevalues$df, escape = FALSE, selection = 'none', editable=TRUE)
### update tablevalues$df with all the edits
observeEvent(input$table1_cell_edit,{
info = input$table1_cell_edit
str(info)
i = info$row
j = info$col
v = as.numeric(info$value) ### change it to info$value if your function does not need it to be numeric
tablevalues$df[i, j] <<- DT::coerceValue(v, tablevalues$df[i, j])
})
mycor <- eventReactive(input$calc1, {
cor(tablevalues$df)
})
output$irr1 <- renderPrint({mycor()})
}
I would like to know if it is possible to use the data described in a textAreaInput in a function.
I need the model described in the text field to be filled in the field specified in the function (my_model), replacing "dmodel()".
This is my code:
library(shiny)
library(shinydashboard)
library(shinyWidgets)
library(readxl)
library(tidyverse)
library(readxl)
library(stringr)
library(psych)
library(MPsychoR)
library(ggplot2)
library(semPlot)
library(lavaan)
# Dashboard
ui <- fluidPage(
titlePanel("CFA"),
sidebarLayout(
sidebarPanel(
h4("Model")
),
# Show a plot of the generated distribution
mainPanel(
box(
textAreaInput(
width = 2000,
"dmodel", "Insert the model"),
br(),
box(
width = 2000,
plotOutput("cfagra")
),
box(
width = 2000,
verbatimTextOutput("cfares")
)
),
)
)
)
# Server
server <- function(input, output, session) {
# Copy the model for functions
dmodel <- reactive({
as.data.frame(input$dmodel)
})
# CFA Synthesis
output$cfares <-
renderPrint({
# Calculation of CFA
my_model <- 'dmodel()'
fitModel <- lavaan::cfa(my_model, data = csv(),
ordered = names(csv()))
summary(fitModel, standardized=TRUE,fit.measures=TRUE)
modindices(fitModel)
})
# Plot
output$cfagrafico <- renderPlot({
# Calculation of CFA
my_model <- 'dmodel()'
fitModel <- lavaan::cfa(my_model, data = csv(),
ordered = names(csv()))
semPaths(fitModel, what = "est", edge.label.cex = 0.7,
edge.color = 1, esize = 1, sizeMan = 4.5, asize = 2.5,
intercepts = FALSE, rotation = 4, thresholdColor = "red",
mar = c(1, 5, 1.5, 5), fade = FALSE, nCharNodes = 4)
summary(fitModel, standardized=TRUE,fit.measures=TRUE)
modindices(fitModel)
})
}
# App
shinyApp(ui = ui, server = server)
Based on lavaan documentation, my_model should be a string.
First,
dmodel <- reactive({
input$dmodel
})
and then call the reactive value without quotes.
output$cfares <-
renderPrint({
# Calculation of CFA
my_model <- dmodel()
fitModel <- lavaan::cfa(my_model, data = csv(),
ordered = names(csv()))
summary(fitModel, standardized=TRUE,fit.measures=TRUE)
modindices(fitModel)
})
I am using googleway library in Shiny R.
The heatmap displays correctly, but I cannot change the heatmap options. If I uncomment the block code where I try to change options, the app crashes.
Here is the part of the code that works, with the offending lines commented out.
library(googleway)
library(magrittr)
library(shiny)
library(shinydashboard)
# Define UI for app
header1 <- dashboardHeader(
title = "My Dashboard"
)
sidebar1 <- dashboardSidebar(
sidebarMenu(
fileInput("file0", "Choose CSV File",
multiple = TRUE,
accept = c("text/csv",
"text/comma-separated-values,text/plain",".csv")),
sliderInput("opacity", "Opacity:",
min = 0, max = 1,
value = 0.5, step = 0.05),
sliderInput("radius", "Radius:",
min = 0, max = 50,
value = 25),
sliderInput("blur", "Blur:",
min = 0, max = 1,
value = 0.75, step = 0.05),
sliderInput("maxvalue", "MaxValue:",
min = 0, max = 1,
value = 1, step = 0.05)
) #sidebarMenu
) #dashboardSidebar
body1 <- dashboardBody(
fluidRow(
tabBox(
title = "TabBox Title 1",
id = "tabset1", height = "400px", width = 11,
selected = "Tab1",
tabPanel("Tab1",
google_mapOutput("Map1")
),
tabPanel("Tab2", "Tab content 2")
) #box
) #fluidRow
) #dashboardBody
ui <- dashboardPage(header1, sidebar1, body1)
# Define data
df <- data.frame(lat = c(14.61),
lon = c(-90.54),
weight = c(100))
# Define SERVER logic
server <- function(input, output, session) {
map_key <- "my_key"
## https://developers.google.com/maps/documentation/javascript/get-api-key
## plot the map
output$Map1 <- renderGoogle_map({
google_map(key = map_key, data = df, zoom = 2, search_box = F) %>%
add_heatmap(weight = "weight") #%>%
#add_traffic()
}) #renderGoogle_map
observeEvent(input$opacity, {
# THIS PART IS COMMENTED OUT BECAUSE THE APP CRASHES
# google_map_update(map_id = "Map1") %>%
# update_heatmap(data = df, option_opacity = input$opacity)
}) #observeEvent
} #server
# Run app
shinyApp(ui, server)
Your help with this will be greatly appreciated! :)
You can use a reactive({}) to carry the input$opacity value and pass it directly to add_heatmap() to achieve the opacity responsiveness.
This can still be done inside the google_map_update(), but you'd have to clear the heatmap layer first, otherwise you'd just be adding layers on top of each other.
server <- function(input, output, session) {
map_key <- "your_key"
## https://developers.google.com/maps/documentation/javascript/get-api-key
opacity <- reactive({
return(input$opacity)
})
## plot the map
output$Map1 <- renderGoogle_map({
google_map(key = map_key, data = df, zoom = 2, search_box = F) %>%
add_heatmap(weight = "weight") #%>%
#add_traffic()
}) #renderGoogle_map
observeEvent(input$opacity, {
google_map_update(map_id = "Map1") %>%
clear_heatmap() %>%
add_heatmap(data = df, option_opacity = opacity())
})
}
} #server
I am running the current version of RStudio, R, and all R packages.
In the sample code below, my goal is to set the maximum value for the xcol and ycol so they are limited to the number of columns in the dataframe that is being plotted. The code below results in the error "object 'input' not found." I suspect the problem may be that I am making the widgets in the ui dependent, but that is a guess on my part. Is that the problem, and is there a strategy that I can use to get around it.
I reviewed posts that contained the same error, but couldn't find anything that answered my question (or didn't recognize when it was answered.) The closest posts to my issue were: R Shiny error: object input not found; R Shiny renderImage() does not recognize object 'input'; Error in eval: object 'input' not found in R Shiny app; Conditional initial values in shiny UI?
Here is some reproducible code with random data.
library(tidyverse)
library(cluster)
library(vegan)
library(shiny)
dta <- rnorm(100, mean = 0, sd = 1)
mat <- matrix(dta, nrow = 10)
dm <- daisy(mat, metric = "euclidean") %>% as.matrix()
server <- function(input, output) {
output$plot <- renderPlot({
nmds <- metaMDS(dm, distance = "euclidean", k = input$dim, trymax = 2000, autotransform = FALSE, noshare = FALSE, wascores = FALSE)
df <- nmds$points %>% as.data.frame()
plot(df[,input$xcol], df[,input$ycol])
}, height = 500, width = 500)
}
ui <- fluidPage(
sidebarLayout(
sidebarPanel(
numericInput("dim", "Number of dimensions", value = 2, min = 2, max = 12),
numericInput("xcol", "X column", value = 1, min = 1, max = input$dim),
numericInput("ycol", "Y column", value = 2, min = 1, max = input$dim)
),
mainPanel(
plotOutput("plot")
)
)
)
You can use updateNumericInput to modify the UI from the server:
# Modify ui to use initial max
ui <- fluidPage(
sidebarLayout(
sidebarPanel(
numericInput("dim", "Number of dimensions", value = 2, min = 2, max = 12),
numericInput("xcol", "X column", value = 1, min = 1, max = 2),
numericInput("ycol", "Y column", value = 2, min = 1, max = 2)
),
mainPanel(
plotOutput("plot")
)
)
)
# Modify server to update max when dim changes
# (notice the session parameter needed for updateNumericInput)
server <- function(input, output, session) {
output$plot <- renderPlot({
if(input$xcol>input$dim)
updateNumericInput(session, "xcol", value=input$dim, max=input$dim)
else
updateNumericInput(session, "xcol", max=input$dim)
if(input$ycol>input$dim)
updateNumericInput(session, "ycol", value=input$dim, max=input$dim)
else
updateNumericInput(session, "ycol", max=input$dim)
nmds <- metaMDS(dm, distance = "euclidean", k = input$dim, trymax = 2000, autotransform = FALSE, noshare = FALSE, wascores = FALSE)
df <- nmds$points %>% as.data.frame()
plot(df[,min(input$dim,input$xcol)], df[,min(input$dim,input$ycol)])
}, height = 500, width = 500)
}