Вы можете попытаться использовать гиперссылку в качестве родителя, а затем изменить внутренние элементы при наведении. Например:
a.active h1 {color:red;}
a.active:hover h1 {color:green;}
a.active h2 {color:blue;}
a.active:hover h1 {color:yellow;}
Таким образом вы можете изменить стиль во множестве внутренних тегов на основе опрокидывания родительского элемента.
, возможно, также не совсем то, что вы ищете, но может сделать трюк (по крайней мере, на могучем Linux). Для меня это работает так, как я хочу, так как я использую скрипты bash, которые запускаются R shiny, и я хочу, чтобы их можно было прервать. Итак, как насчет размещения вашего R-кода в сценарии и запуска скрипта с помощью системной команды?
В приведенном ниже примере я просто использую простой сценарий манекена bash, который запускает команду sleep, тогда как первый аргумент CL количество сна. Все, что находится ниже 10 секунд, не принимается и ставит статус выхода в 1. Кроме того, я получаю некоторый вывод в файле журнала, который я могу контролировать, и, следовательно, прогресс в реальном времени.
Надеюсь, вы найдете это полезным.
library(shiny)
ui <- fluidPage(
# we need this to send costumized messages
tags$head(tags$script(HTML('Shiny.addCustomMessageHandler("jsCode",function(message) {eval(message.value);});'))),
# Sidebar with a slider input for number of bins
sidebarLayout(
sidebarPanel(
textInput("duration", "How long you want to wait?"),hr(),
p("Are you experienced?"),
actionButton("processbtn", "Yes"),hr(),
p("Show me what's going on"),
actionButton("logbtn", "Show me by clicking here."),hr(),
p("Tired of being experienced?"),
actionButton("abortbtn", "Yes")
), # close sidebar panel
# Show a plot of the generated distribution
mainPanel(
textOutput("outText"),hr(),
verbatimTextOutput("outLog")
) # close mainpanel
) # close sidebar
) # close fluidpage
#------SERVER------------
# Define server logic required to draw a histogram
server <- function(input, output, session) {
# our reactive values that change on button click by the observe functions below
values <- reactiveValues(process = 0, abort = 0, log = 0)
observeEvent(input$processbtn, {
values$process = 1
values$abort = 0
values$log = 0
})
observeEvent(input$abortbtn, {
values$process = 0
values$abort = 1
})
observeEvent(input$logbtn, {
values$log = 1
})
current_state = function(exitfile) {
# get the pid
pid = as.integer(system2("ps", args = "-ef | grep \"bash ~/dummy_script.sh\" | grep -v grep | awk '{print $2}'", stdout = TRUE))
print(pid)
if (length(pid) > 0)
return("RUNNING")
if (file.exists(exitfile))
return("TERMINATED")
return("NOT_STARTED")
}
start_function = function(exitfile) {
if(input$duration == "") {
end_message="The text input field is empty!"
js_string <- 'alert("SUCCESS");'
js_string <- sub("SUCCESS",end_message,js_string)
session$sendCustomMessage(type='jsCode', list(value = js_string))
values$process = 0
return("NOT_STARTED")
} else { # all checks are fine. send a message and start processing
end_message="We start waiting, yeah!!!"
js_string <- 'alert("SUCCESS");'
js_string <- sub("SUCCESS",end_message,js_string)
session$sendCustomMessage(type='jsCode', list(value = js_string))
# here we execute the outsourced script and
# write the exit status to a file, so we can check for that and give an error message
system(paste("( bash ~/dummy_script.sh", input$duration,"; echo $? >", exitfile, ")"), wait = FALSE)
return("RUNNING")
}
}
on_terminated = function(exitfile) {
# get the exit state of the script
status = readLines(exitfile)
print(status)
# we want to remove the exit file for the next run
unlink(exitfile, force = TRUE)
# message when we finished
if ( status != 0 ){
end_message="Duration is too short."
js_string <- 'alert("SUCCESS");'
js_string <- sub("SUCCESS",end_message,js_string)
session$sendCustomMessage(type='jsCode', list(value = js_string))
}
else {
end_message="Success"
js_string <- 'alert("SUCCESS");'
js_string <- sub("SUCCESS",end_message,js_string)
session$sendCustomMessage(type='jsCode', list(value = js_string))
}
values$process = 0
}
# our main processing fucntion
output$outText = renderText({
# trigger processing when action button clicked
if(values$process) {
# get the homefolder
homedir=Sys.getenv("HOME")
# create the path for an exit file (we'll need to evaluate the end of the script)
exitfile=file.path(homedir, "dummy_exit")
print(exitfile)
state = current_state(exitfile) # Can be NOT_STARTED, RUNNING, COMPLETED
print(state)
if (state == "NOT_STARTED")
state = start_function(exitfile)
if (state == "RUNNING")
invalidateLater(2000, session = getDefaultReactiveDomain())
if (state == "TERMINATED")
on_terminated(exitfile)
# Abort processing
} else
if(values$abort) {
pid = as.integer(system2("ps", args = "-ef | grep \"bash ~/dummy_script.sh\" | grep -v grep | awk '{print $2}'", stdout = TRUE))
print(pid)
system(paste("kill", pid), wait = FALSE)
}
}) # close renderText function
output$outLog = renderText({
if(values$log) {
homedir=Sys.getenv("HOME")
logfile=file.path(homedir, "/dummy_log")
if(file.exists(logfile)){
invalidateLater(2000)
paste(readLines(logfile), collapse = "\n")
}
else {
print("Nothing going on here")
}
}
})
} # close server
# Run the application
shinyApp(ui = ui, server = server)
Как насчет httpuv :: service ()?
library(shiny)
analyze <- function(session=shiny::getDefaultReactiveDomain()){
continue = TRUE
lapply(1:100, function(x) {
if(continue){
print(x)
Sys.sleep(1)
# reload inputs
httpuv:::service()
continue <<- !isTRUE(session$input$stopThis)
}
}
)
}
shinyApp(
ui = fluidPage(
actionButton("start","Start",class="btn-primary", onclick="Shiny.onInputChange('stopThis',false)"),
actionButton("stop","Stop",class="btn-danger", onclick="Shiny.onInputChange('stopThis',true)")
),
server = function(input, output, session) {
observeEvent(input$start, {
analyze()
})
}
)
mcparallel
не определен (может быть, мне нужна более новая версия пакета parallel
? Или это из другого пакета?). Но я вижу, что вы делаете, и да, я думаю, что это сработает. Это не самое приятное решение, но хорошо, что вы разместили это здесь, чтобы, если кто-то должен это сделать, они узнают об этом. Благодаря!
– Dean Attali
30 December 2015 в 01:41
Если вы можете разделить вычисления сверхмощных операций на несколько частей или получить доступ к той части кода, которая участвует в вычислении, вы можете вставить часть выключателя. Я реализовал это в Shiny app , который прослушивает нажатие кнопки, прежде чем продолжить с остальными вычислениями. Вы можете запустить приложение из R с помощью
library(shiny)
runGitHub("romunov/shinyapps", subdir = "breaker")
или скопировать / вставить код в сервер.R и ui.R и запустить его с помощью runApp()
.
#ui.R
library(shiny)
shinyUI(fluidPage(
titlePanel("Interrupting calculation"),
sidebarLayout(
sidebarPanel(
sliderInput(inputId = "num.rows",
label = "Generate number of rows",
min = 1e1,
max = 1e7,
value = 3e3),
actionButton(inputId = "ok", label = "Stop computation")
),
mainPanel(
verbatimTextOutput("result")
)
)
))
#server.R
library(shiny)
shinyServer(function(input, output) {
initial.ok <- 0
part1 <- reactive({
nr.f <- floor(input$num.rows/2)
out1 <- data.frame(col = sample(letters[1:5], size = nr.f,
replace = TRUE),
val = runif(nr.f))
out1
})
part2 <- reactive({
nr.c <- ceiling(input$num.rows/2)
out2 <- data.frame(col = sample(letters[1:5], size = nr.c,
replace = TRUE),
val = runif(nr.c))
out2
})
output$result <- renderPrint({
out1 <- part1()
if (initial.ok < input$ok) {
initial.ok <<- initial.ok + 1
stop("Interrupted")
}
out2 <- part2()
out <- rbind(out1, out2)
print("Successful calculation")
print(str(out))
})
})