TarJae's questions

Estou construindo um aplicativo Shiny usando shinyscreenshot. Meu aplicativo inclui um cartão "Pontuação" com uma lista de radioGroupButtons que os usuários podem selecionar. Os radioGroupButtons não são visíveis no aplicativo, no entanto, quando tiro uma captura de tela usando shinyscreenshot, os radioGroupButtons ocorrem e se sobrepõem aos valores numéricos, deixando a captura de tela confusa.

Quero ocultar os radioGroupButtons ao tirar a captura de tela. Tentei usar shinyjs para alternar a visibilidade dos botões, mas não está funcionando como esperado.

Aqui está um exemplo mínimo reproduzível que demonstra minha configuração e abordagem:

library(shiny)
library(bs4Dash)
library(shinyWidgets)
library(shinyjs)
library(shinyscreenshot)

my_ids <- c("region_1", "region_2") 
my_labels <- c("A", "B") 

ui <- bs4DashPage(
  title = "My Example",
  header = bs4DashNavbar(),
  sidebar = bs4DashSidebar(disable = TRUE),  
  body = bs4DashBody(
    useShinyjs(),
    
    # CSS for radio button styles and hiding elements
    tags$style(HTML("
      .btn-zero {background-color: white; color: black;}
      .btn-zero.active {background-color: #a2ff45; color: black;}
      .btn-one {background-color: white; color: black;}
      .btn-one.active {background-color: #a2ff45; color: black;}
      .btn-two {background-color: white; color: black;}
      .btn-two.active {background-color: #a2ff45; color: black;}
      .btn-three {background-color: white; color: black;}
      .btn-three.active {background-color: #a2ff45; color: black;}
      .region-label { line-height: 2.5; }

      /* Hide elements during screenshot */
      .hide-for-screenshot { display: none !important; }
    ")),
    
    bs4Card(
      title = "My Score",
      width = 6,
      style = "height: 200px; overflow: auto;",  
      tags$style(HTML("
        .region-label { margin-top: -10px; }
      ")),
      # Render radio buttons for each region
      lapply(seq_along(my_ids), function(i) {
        fluidRow(
          column(6, h4(class = "region-label", paste(i-1, my_labels[i]))),
          column(6, div(
            style = "display: inline-block;",
            shinyWidgets::radioGroupButtons(
              inputId = my_ids[i],
              label = NULL,
              choices = 0:3,
              selected = 0,
              checkIcon = list(yes = icon("check")),
              status = c("zero", "one", "two", "three"),
              size = 'xs'
            )
          ))
        )
      })
    ),
    
    # Screenshot Button
    actionButton("take_screenshot", "Take Screenshot", style = "margin-top: 10px;")
  )
)

server <- function(input, output, session) {
  observeEvent(input$take_screenshot, {
    # Temporarily hide radio buttons
    shinyjs::addClass(selector = ".radioGroupButtons", class = "hide-for-screenshot")
    
    # Take screenshot and remove the hide class afterward
    shinyscreenshot::screenshot()
    
    # Show radio buttons again
    shinyjs::removeClass(selector = ".radioGroupButtons", class = "hide-for-screenshot")
  })
}

shinyApp(ui, server)

O que eu tentei CSS personalizado: adicionei uma .hide-for-screenshotclasse CSS com display: none !important; para ocultar elementos. A classe é aplicada logo antes de tirar a captura de tela e removida depois.

Usando shinyjs: Estou usando shinyjs::addClasse shinyjs::removeClasspara alternar a .hide-for-screenshotclasse no radioGroupButtons.

Problema Apesar de adicionar a hide-for-screenshotclasse e ocultá-la radioGroupButtonsantes de tirar a captura de tela, elas ainda aparecem na captura de tela. Suspeito que isso shinyscreenshotpode não estar respeitando as alterações temporárias de CSS ou que o atraso não é suficiente para aplicar o estilo.

Pergunta Como posso garantir que eles radioGroupButtonsfiquem completamente ocultos ao shinyscreenshotcapturar a tela?

Quaisquer sugestões ou abordagens alternativas seriam muito apreciadas! Obrigado.

A captura de tela se parece com isso:

Deve ficar assim:

Estou encontrando um problema ao usar tidymodels com xgboost em um fluxo de trabalho. Após aplicar uma receita que inclui step_dummy()converter variáveis ​​categóricas em variáveis ​​fictícias, recebo o seguinte erro ao tentar fazer previsões:

Error in `validate_column_names()`:
! The following required columns are missing: 'A', 'B', 'C', 'D'.

Aqui está uma versão simplificada do meu código:

library(tidymodels)
library(xgboost)
library(dplyr)

set.seed(123)
datensatz <- tibble(
  outcome = rnorm(100, mean = 60, sd = 10),
  A = factor(sample(c("h", "i", "j"), 100, replace = TRUE)),
  B = factor(sample(c("e", "f", "g"), 100, replace = TRUE)),
  C = factor(sample(1:3, 100, replace = TRUE)),
  D = factor(sample(c("a", "b"), 100, replace = TRUE))
)

# splitting
data_split <- initial_split(datensatz, prop = 0.75)
train_data <- training(data_split)
test_data <- testing(data_split)


# Rezept
recipe_obj <- recipe(outcome ~ ., data = train_data) %>%
  step_dummy(all_nominal(), -all_outcomes()) %>%  
  step_zv(all_predictors()) %>%  
  step_normalize(all_numeric_predictors())  

prepared_recipe <- prep(recipe_obj)
test_data_prepared <- bake(prepared_recipe, new_data = test_data)

# XGBoost Modell Spezifikation
xgboost_spec <- boost_tree(
  trees = 1000,                    
  tree_depth = 6,                  
  min_n = 10,                      
  loss_reduction = 0.01,           
  sample_size = 0.8,               
  mtry = 0.8,                      
  learn_rate = 0.01                
) %>%
  set_mode("regression") %>%
  set_engine("xgboost", count = FALSE, colsample_bytree = 0.8)

# Workflow
workflow_obj <- workflow() %>%
  add_recipe(recipe_obj) %>%
  add_model(xgboost_spec)

# Modell trainieren
xgboost_fit <- fit(workflow_obj, data = train_data)

# Modellvorhersage auf den vorbereiteten Testdaten
predictions <- predict(xgboost_fit, new_data = test_data_prepared)

# Ergebnisse 
predictions
# Error occurs here

Suspeito que o problema esteja relacionado ao fato de que step_dummy()remove as colunas categóricas originais (A, B, C, D)e as substitui por variáveis ​​fictícias. No entanto, o fluxo de trabalho parece esperar as colunas originais ao fazer previsões.

Como posso resolver esse problema e garantir que a etapa de previsão use corretamente as variáveis ​​fictícias criadas por step_dummy()?

Informações adicionais:

I'm using the `xgboost engine` within the `tidymodels` framework.
The error message suggests that the workflow expects the original categorical variables, but these are no longer present after applying `step_dummy()`.

Eu tenho dois tibbles com valores únicos, com comprimentos desiguais, como:

df1 <- structure(list(col1 = c("A", "T", "C", "D", "X", "F")), class = c("tbl_df", "tbl", "data.frame"), row.names = c(NA, -6L))
df2 <- structure(list(col2 = c("A", "B", "C", "D", "E", "F", "G", "H", "I", "J")), class = c("tbl_df", "tbl", "data.frame"), row.names = c(NA, -10L))

> df1
# A tibble: 6 × 1
  col1 
  <chr>
1 A    
2 T    
3 C    
4 D    
5 X    
6 F 

> df2
# A tibble: 9 × 1
  col2 
  <chr>
1 A    
2 B    
3 C    
4 D    
5 F    
6 G    
7 H    
8 I    
9 J   

Eu gostaria de obter:

> df3
# A tibble: 11 × 2
   col1  col2 
   <chr> <chr>
 1 A     A    
 2 NA    B    
 3 T     NA   
 4 C     C    
 5 D     D    
 6 X     NA   
 7 F     F    
 8 NA    G    
 9 NA    H    
10 NA    I    
11 NA    J

Cada string idêntica em col1 de df1 e col2 em df2 deve estar na mesma linha lado a lado. Por exemplo, se uma string em col1 e col2 for a mesma, elas deverão estar na mesma linha (por exemplo, string A). Se existir uma string em col1, mas não em col2, ela deverá ser NA em col2 e vice-versa.

Eu ficaria grato por qualquer conselho adicional.

Estou tentando criar um gráfico de calor para dados em escala Likert usando o likertpacote em R e quero agrupar os rótulos do eixo y str_wrappara torná-los mais legíveis. Porém, quando utilizo str_wrapwith scale_y_discrete, a ordem dos rótulos muda para ordem alfabética ao invés de preservar a ordem original.

MRE com e sem comentários de scale_y_discrete(labels = function(x) str_wrap(x, width = 5)):

library(likert)
library(ggplot2)
library(stringr)
library(dplyr)

diamonds %>%
  select(cut) %>%
  as.data.frame() %>%
  likert() %>%
  plot(., type = "heat") +
  # scale_y_discrete(labels = function(x) str_wrap(x, width = 5))
  NULL

Quando eu uso scale_y_discrete(labels = str_wrap), os rótulos do eixo y são agrupados corretamente, mas a ordem dos rótulos é alterada para ordem alfabética. Quero preservar a ordem original dos rótulos como em original_levels. Pergunta:

Como posso agrupar os rótulos do eixo str_wrapy preservando a ordem original ggplot2?

Tenho certeza de que o problema é causado pela conversão de cutum fator em uma classe de personagem. No entanto, não consigo resolver esse problema.

Qualquer ajuda ou orientação sobre como conseguir isso seria muito apreciada!

Costumo usar tibbles e estou bastante satisfeito com eles. O único problema recorrente que me incomoda é ter que adicionar constantemente print(n = ...)toda vez que quero visualizar mais de 10 linhas. Estou ciente de que poderia convertê-los em quadros de dados usando as.data.frame(), mas prefiro definir uma opção de impressão global, como print(n=100), para todos os tibbles até decidir alterá-la.

Até agora, o que tenho feito é

usandoprint(n=....)

library(dplyr)

mtcars %>% 
  as_tibble() %>% 
  print(n=20)

ou usandoas.data.frame()

mtcars %>% 
  as_tibble() %>% 
  as.data.frame()

ou com uma função personalizada (semelhante ao recurso data.table)

tar_head_tail <- function(data, nh = 15, nt = 15) {
  library(dplyr)
  library(crayon)
  
  x <- data %>%
    as.data.frame() %>%
    tibble::rownames_to_column("row_number") %>%
    head(n = nh)
  
  y <- data %>%
    as.data.frame() %>%
    tibble::rownames_to_column("row_number") %>%
    tail(n = nt)
  
  head_tail <- bind_rows(x, y) %>%
    tibble::column_to_rownames("row_number")
  
  # Apply color
  cat(green("Head:\n"))
  print(x)
  cat(red("\nTail:\n"))
  print(y)
  
  return(invisible(head_tail))
}

iris %>% 
  tar_head_tail()

Como podemos definir uma opção de impressão global (como print(n=20)) para todos os tibbles até decidirmos alterá-la?

Atualização: O que espero:

Quando eu faço:

mtcars %>% 
  as_tibble()

deve aparecer após definir global print(n=20):

# A tibble: 32 × 11
     mpg   cyl  disp    hp  drat    wt  qsec    vs    am  gear  carb
   <dbl> <dbl> <dbl> <dbl> <dbl> <dbl> <dbl> <dbl> <dbl> <dbl> <dbl>
 1  21       6 160     110  3.9   2.62  16.5     0     1     4     4
 2  21       6 160     110  3.9   2.88  17.0     0     1     4     4
 3  22.8     4 108      93  3.85  2.32  18.6     1     1     4     1
 4  21.4     6 258     110  3.08  3.22  19.4     1     0     3     1
 5  18.7     8 360     175  3.15  3.44  17.0     0     0     3     2
 6  18.1     6 225     105  2.76  3.46  20.2     1     0     3     1
 7  14.3     8 360     245  3.21  3.57  15.8     0     0     3     4
 8  24.4     4 147.     62  3.69  3.19  20       1     0     4     2
 9  22.8     4 141.     95  3.92  3.15  22.9     1     0     4     2
10  19.2     6 168.    123  3.92  3.44  18.3     1     0     4     4
11  17.8     6 168.    123  3.92  3.44  18.9     1     0     4     4
12  16.4     8 276.    180  3.07  4.07  17.4     0     0     3     3
13  17.3     8 276.    180  3.07  3.73  17.6     0     0     3     3
14  15.2     8 276.    180  3.07  3.78  18       0     0     3     3
15  10.4     8 472     205  2.93  5.25  18.0     0     0     3     4
16  10.4     8 460     215  3     5.42  17.8     0     0     3     4
17  14.7     8 440     230  3.23  5.34  17.4     0     0     3     4
18  32.4     4  78.7    66  4.08  2.2   19.5     1     1     4     1
19  30.4     4  75.7    52  4.93  1.62  18.5     1     1     4     2
20  33.9     4  71.1    65  4.22  1.84  19.9     1     1     4     1
# ℹ 12 more rows

Quero evitar a linha adicional de print(n=....), ou print()etc ...

Não há nenhum histórico especial, só estou curioso para saber se há alguma consideração a respeito:

Até onde sei, em R não é possível incluir um comentário e uma nova linha de código na mesma linha, veja o comentário @Ben Bolker , conforme demonstrado neste exemplo:

Encontrei isso em 2018 stackoverflow e isso em 2022 stackoverflow . Este último usando uma função personalizada %com%que não funcionou para mim:

library(dplyr)

`%com%` <- function(lhs, rhs){
  lhs #rhs
}

mtcars %>% 
  select(cyl, mpg, %com%am, wt) %>% 
  head()

Error: unexpected SPECIAL in:
"mtcars %>% 
  select(cyl, mpg, %com%"

Eu costumo gostar de:

mtcars %>% 
  select(cyl, mpg, 
         #am, 
         wt) %>% 
  head()

Como posso calcular col2?

col2deve aumentar cada vez que um valor em col1aparece após ser interrompido por um valor diferente, por exemplo, criando uma variável de agrupamento que muda toda vez que uma nova sequência é iniciada.

structure(list(col1 = c("A", "A", "A", "A", "B", "B", "B", "C", 
"C", "C", "C", "A", "A", "E", "E", "E", "F", "F", "F", "G", "G", 
"G", "C", "C", "C", "A", "A", "A"), col2 = c(1L, 1L, 1L, 1L, 
1L, 1L, 1L, 1L, 1L, 1L, 1L, 2L, 2L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 
1L, 1L, 2L, 2L, 2L, 3L, 3L, 3L)), class = "data.frame", row.names = c(NA, 
-28L))

Saída desejada:

   col1 col2
1     A    1
2     A    1
3     A    1
4     A    1
5     B    1
6     B    1
7     B    1
8     C    1
9     C    1
10    C    1
11    C    1
12    A    2
13    A    2
14    E    1
15    E    1
16    E    1
17    F    1
18    F    1
19    F    1
20    G    1
21    G    1
22    G    1
23    C    2
24    C    2
25    C    2
26    A    3
27    A    3
28    A    3

A orderInput()função do shinyjquipacote utiliza seis classes de botões Bootstrap predefinidas para estilizar os itens que exibe. Esses estilos podem ser especificados usando o item_classparâmetro. Para mais detalhes, consulte a documentação .

Tento adicionar classes adicionais, a função orderInput(), que parece ter sido projetada para aceitar apenas as seis classes de botão Bootstrap defaultpredefinidas ( ,,,,,,, ) .primarysuccessinfowarningdanger

Isso é possível?

library(shiny)
library(shinyjqui)

ui <- fluidPage(
  tags$head(
    tags$style(
      HTML("
            .grey { background-color: grey; color: white; }
           ")
    )
  ),
  
  uiOutput("custom_orderInput")
)

server <- function(input, output, session) {
  
  output$custom_orderInput <- renderUI({
    
    tagList(
      orderInput('default', 'default', items = 1:3, item_class = 'default'),
      orderInput('primary', 'primary', items = 1:3, item_class = 'primary'),
      orderInput('success', 'success', items = 1:3, item_class = 'success'),
      orderInput('info', 'info', items = 1:3, item_class = 'info'),
      orderInput('warning', 'warning', items = 1:3, item_class = 'warning'),
      orderInput('danger', 'danger', items = 1:3, item_class = 'danger'),
      orderInput('grey', 'grey', items = 7:9, item_class = 'grey')
    )
    
  })
  
}

shinyApp(ui, server)

Atualização: Aqui está uma explicação gráfica do que eu quero: Existem recursos: 1. redimensionar com o mouse e 2. girar o texto.

Esta é uma pergunta complementar a este arrastar e soltar com brilhantejqui para uma tabela de grade .

Primeira resposta: estou tentando tornar o item ou botão com o rótulo A redimensionável, como explicado aqui https://yang-tang.github.io/shinyjqui/ : 'Redimensionável: altere o tamanho de um elemento usando o mouse.'

Isso é possível? Tentei a função genérica do pacote jqui_sortablee também um código JS customizado como no exemplo abaixo:

library(shiny)
library(shinyjqui)

connections <- paste0("droppable_cell_", 1) # id of the grid cells

ui <- fluidPage(
  tags$head(
    tags$script(
      JS(
        "
$(document).on('shiny:connected', function() {
$('#letters').resizable({
alsoResize: '.shinyjqui-sortable-item',
minHeight: 20,
minWidth: 20
});
});


$(function() {
$('[id^=droppable_cell]').sortable({
connectWith: '#letters',
drop: function(event, ui) {
$(this).append(ui.draggable);
}
})
});
"
      )
    ),
# some styling
tags$style(
  HTML(
    "
.grid-table {
width: 150px;
border-collapse: collapse;
}
.grid-cell {
width: 100%;
height: 200px;
border: 1px solid black;
background-color: white;
text-align: center;
margin: 0;
padding: 5px;
}
.grid-cell-text {
display: flex;
align-items: center;
justify-content: center;
height: 100%;
background-color: steelblue;
color: white;
font-size: 18px;
}
.droppable-cell {
background-color: lightgray;
}
.table-container {
display: flex;
position: absolute;
left: 10px;
top: 10px;
margin-top: 0px;
overflow: hidden;
}
"
  )
)
  ),

div(
  class = "table-container",
  div(
    class = "grid-table",
    id = "my_grid",
    div(
      class = "grid-row",
      div(class = "grid-cell grid-cell-text", "my_grid"),
      div(id = "droppable_cell_1", class = "grid-cell droppable-cell", ""),
    )
  ),
  
  orderInput('letters', 'Letters', items = LETTERS[1],
             connect = connections) # defined above
)
)

server <- function(input, output, session) {
  
}

shinyApp(ui, server)