Nothing
.makePartitionDf <- function(){
if (length(values$partitions) == 0){
df <- data.frame(name = character(), corpus = character(), size = integer())
} else {
df <- data.frame(
name = sapply(values$partitions, function(x) x@name),
corpus = sapply(values$partitions, function(x) x@corpus),
size = sapply(values$partitions, function(x) x@size)
)
}
df
}
#' Building blocks for shiny apps and widgets.
#'
#'
#' @param input input
#' @param output output
#' @param session session
#' @param drop elements to drop
#' @param ... further parameters
#' @rdname shiny_helper_functions
#' @export partitionUiInput
#' @import methods
#' @importFrom DT renderDataTable dataTableOutput
partitionUiInput <- function(){
list(
go = actionButton("partition_go", label="", icon = icon("play", lib="glyphicon")),
delete = actionButton("partition_delete", label = "", icon = icon("trash", lib = "glyphicon")),
code = actionButton("partition_code", label = "", icon = icon("code", lib = "font-awesome")),
br(),
br(),
corpus = selectInput("partition_corpus", "corpus", choices = corpus()[["corpus"]], selected = corpus()[["corpus"]][1]),
name = textInput(inputId = "partition_name", label = "name", value = "unnamed"),
s_attributesA = selectInput(
inputId = "partition_s_attributes", label = "s_attributes", multiple = TRUE,
choices = s_attributes(corpus()[["corpus"]][1])
),
s_attributesB = uiOutput("partition_s_attributes"),
p_attribute = selectInput(inputId = "partition_p_attribute", label = "p_attribute", multiple = TRUE, choices = list(none = "", word = "word", lemma = "lemma")),
regex = radioButtons("partition_regex", "regex", choices = list("TRUE", "FALSE"), inline = TRUE),
xml = radioButtons("partition_xml", "xml", choices = list("flat", "nested"), inline = TRUE)
)
}
#' @rdname shiny_helper_functions
#' @export partitionUiOutput
partitionUiOutput <- function(){
DT::dataTableOutput('partition_table')
}
#' @rdname shiny_helper_functions
#' @export partitionServer
partitionServer <- function(input, output, session){
# necessary (for a reason unknown) to get table filled upon starting app
output$partition_table <- DT::renderDataTable(.makePartitionDf())
observeEvent(
input$partition_go,
{
if (input$partition_go > 0){
defList <- lapply(
setNames(input$partition_s_attributes, input$partition_s_attributes),
function(x) input[[x]]
)
# to avid an error, do nothing if no s_attribute value is available/has been entered
if (length(input$partition_s_attributes) > 0 && !any(sapply(defList, is.null))){
noMessages <- 3L + if (is.null(input$partition_p_attribute)) 0L else 1L
withProgress(
message = "please wait ...", value = 0, max = noMessages, detail = "getting started",
{
P <- partition(
as.character(input$partition_corpus),
def = defList,
name = input$partition_name,
p_attribute = input$partition_p_attribute,
regex = if (input$partition_regex == "TRUE") TRUE else FALSE,
xml = input$partition_xml,
mc = FALSE,
verbose = "shiny"
)
}
)
values$partitions[[input$partition_name]] <- P
}
# update table with partitions
partitionDf <- .makePartitionDf()
output$partition_table <- DT::renderDataTable(partitionDf)
# make partitions available to functions
selectInputToUpdate <- c("kwic_partition", "cooccurrences_partition", "dispersion_partition", "features_partition_x", "features_partition_y", "count_partition")
for (toUpdate in selectInputToUpdate) {
updateSelectInput(session, toUpdate, choices = names(values$partitions), selected = NULL)
}
}
}
)
observeEvent(input$partition_code, {
s_attrs <- paste(sapply(input$partition_s_attributes, function(x) sprintf(' %s = "%s"', x, input[[x]])), collapse = ",\n")
snippet <- sprintf(
'partition(\n %s,\n%s,\n p_attribute = "%s",\n regex = %s,\n xml = "%s"\n)',
input$partition_corpus,
s_attrs,
if (length(input$partition_p_attribute) == 0L) "" else input$partition_p_attribute,
input$partition_regex,
input$partition_xml
)
snippet_html <- highlight::highlight(
parse.output = parse(text = snippet),
renderer = highlight::renderer_html(document = TRUE),
output = NULL
)
showModal(modalDialog(title = "Code", HTML(paste(snippet_html, collapse = ""))))
})
observeEvent(
input$partition_corpus,
{
updateSelectInput(
session, inputId = "partition_s_attributes",
choices = s_attributes(input$partition_corpus)
)
}
)
observeEvent(
input$partition_corpus,
{
updateSelectInput(
session, inputId = "partition_p_attribute",
choices = p_attributes(input$partition_corpus)
)
}
)
output$partition_s_attributes <- renderUI({
tagList(lapply(
input$partition_s_attributes,
function(x){
selectInput(
inputId = x, label = x, multiple = TRUE,
choices = s_attributes(input$partition_corpus, x)
)
}
))
})
observeEvent(
input$partition_delete,
{
if (length(input$partition_table_rows_selected) > 0){
toDrop <- input$partition_table_rows_selected
for (x in .makePartitionDf()[toDrop]) values$partitions[[toDrop]] <- NULL
output$partition_table <- DT::renderDataTable(.makePartitionDf())
}
})
# used by partitionGadget only
retval <- observeEvent(
input$partition_done,
{
newPartition <- partition(
as.character(input$partition_corpus),
def = lapply(
setNames(input$partition_s_attributes, input$partition_s_attributes),
rectifySpecialChars
),
name = input$partition_name,
p_attribute = input$partition_p_attribute,
regex = input$partition_regex,
xml = input$partition_xml,
mc = FALSE,
verbose = TRUE
)
stopApp(returnValue = newPartition)
}
)
}
#' @export partitionGadget
#' @rdname polmineR_gui
partitionGadget <- function(){
partitionGadgetUI <- miniPage(
theme = shinytheme("cerulean"),
gadgetTitleBar(
"Create partition",
left = miniTitleBarCancelButton(),
right = miniTitleBarButton(inputId = "partition_done", label = "Go", primary = TRUE)
),
miniContentPanel(
fillPage(
fillRow(
fillCol(
div(partitionUiInput()[["corpus"]],
partitionUiInput()[["name"]],
partitionUiInput()[["p_attribute"]],
partitionUiInput()[["regex"]],
partitionUiInput()[["xml"]]
)
),
fillCol(br()),
fillCol(
div(
partitionUiInput()[["s_attributesA"]],
partitionUiInput()[["s_attributesB"]]
)
),
flex = c(1,0.1, 1)
)
),
padding = 10
)
)
returnValue <- runGadget(
app = shinyApp(
ui = partitionGadgetUI,
server = partitionServer
),
viewer = paneViewer()
)
return(returnValue)
}
Any scripts or data that you put into this service are public.
Add the following code to your website.
For more information on customizing the embed code, read Embedding Snippets.