thothal's questions

Aviso legal. Estou trabalhando com R, mas a pergunta é, na verdade, uma pergunta geral plotly(só que sou mais rápido gerando um gráfico em JavaScript Rdo que em JavaScript puro).

Tenho o seguinte código, que adiciona uma borda ao redor da barra ao passar o mouse. Funciona como esperado, MAS a legenda só muda se eu passar o mouse sobre (e, portanto, bordar) a primeira barra do traço.

Gostaria que ela não mudasse nada (solução preferida) ou que a borda fosse adicionada à legenda, independentemente de qual barra do traço eu estiver passando o mouse.

library(plotly)
library(htmlwidgets)
set.seed(29042025)
d <- expand.grid(a = LETTERS[1:3], b = letters[1:2])
d$c <- sample(10, 6)

plot_ly(d) %>%
  add_bars(x = ~ c, y = ~ a, color = ~ b) %>%
  onRender("function(el, x) {
   el.on('plotly_hover', function(data){
     const color = Array(3).fill('undefined');
     const width = Array(3).fill('undefined');
     const pos = data.points[0].pointNumber;
     color[pos] = 'black';
     width[pos] = 2;
     Plotly.restyle(el, {'marker.line': null});
     Plotly.restyle(el, {'marker.line.color': [color], 'marker.line.width': [width]}, [data.points[0].curveNumber]);
   });
  }")

Suponha que eu tenha a seguinte estrutura de dados:

library(dplyr)
d <- tibble(x = paste0("x", 1:3), 
            op = c("f", "g", "h"), 
            y = paste0("y", 1:3), 
            res = paste0("z", 1:3))

Quero criar uma nova coluna cmdque contenha uma chamada não avaliada que deve ficar assim:

(D <- d %>%
  mutate(cmd = list(quote(z1 <- f(x1, y1)), 
                    quote(z2 <- g(x2, y2)), 
                    quote(z3 <- h(x3, y3)))))
# # A tibble: 3 × 5
#   x     op    y     res   cmd       
#   <chr> <chr> <chr> <chr> <list>    
# 1 x1    f     y1    z1    <language>
# 2 x2    g     y2    z2    <language>
# 3 x3    h     y3    z3    <language>

mas é claro que não quero codificar essas linhas, mas queria extrair esses valores das linhas correspondentes de d, mas não tive sucesso:

d %>%
  rowwise() %>%
  mutate(cmd = list(expr(!!sym(res) <- !!sym(op)(!!sym(x), !!sym(y)))))

resulta em:

Error: object 'res' not found

Como eu alcançaria o objetivo?

O NB cmd será finalmente avaliado em um ambiente onde os argumentos e as funções são definidos, então conceitualmente algo como:

e <- list2env(list(x1 = 1, x2 = 2, x3 = 3, y1 = 2, y2 = 2, y3 = 3, 
              f = \(x, y) x + y, g = \(x, y) x - y, h = \(x, y) x * y))

eval(D$cmd[[1]], e)
e$z1
# [1] 3

Estou tentando implementar uma subclasse de tblpara ajustar a maneira como meus dados são impressos. O código é parte de um pacote.

Li a documentação e usei estas linhas:

as_data_test <- function(...) {
  tibble::new_tibble(..., class = "data_test")
}

tbl_format_header.data_test <- function(x, setup, ...) {
  cli::style_italic("A Data Test = ", setup$tbl_sum)
}

Então eu uso devtools::load_all(".")para carregar o pacote. Mas quando tento imprimir meu data_testobjeto, ele não usa a tbl_format_headerfunção personalizada:

devtools::load_all(".")
# i Loading datatesteR
as_data_test(mtcars)
# # A tibble: 32 x 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
# # i 22 more rows
# # i Use `print(n = ...)` to see more rows

Como você pode ver, apenas o cabeçalho padrão é impresso. Colocar uma browserchamada em tbl_format_header.data_testconfirma que meu método nunca é despachado. Se eu colocar o mesmo código diretamente em um console R, tudo funciona perfeitamente.

Como posso obter a impressão personalizada no meu devtoolsfluxo de trabalho?

Suponha que eu tenha um reactiveque retorna um data.frame. Quero que alguns dos meus controles tomem uma dependência somente em um subconjunto de suas colunas, ou seja, eles devem disparar somente se os valores em qualquer uma das colunas "relevantes" (aqui rel_1e rel_2) mudarem, enquanto as alterações nas colunas "irrelevantes" (aqui irr_1e irr_2) não devem disparar uma atualização.

Achei que criar um reactiveque retornasse apenas as colunas relevantes resolveria o problema, mas o código a seguir mostra que todos os botões acionam uma atualização do verbatimTextOutput. Minha expectativa seria que pressionar para Alterar Colunas Irrelevantes não acionaria uma atualização, porque os valores nas colunas relevantes permanecem inalterados.

library(shiny)
library(DT)
library(dplyr)
library(glue)

dat <- tibble(
  rel_1 = LETTERS[1:3],
  rel_2 = letters[1:3],
  irr_1 = 1:3,
  irr_2 = 101:103
)

ui <- fluidPage(
  fluidRow(
    column(
      width = 4,
      actionButton("chng_all", "Change All Columns")
    ),
    column(
      width = 4,
      actionButton("chng_irr", "Change Irrelevant Columns")
    ),
    column(
      width = 4,
      actionButton("chng_rel", "Change Relevant Columns")
    )
  ),
  fluidRow(
    column(
      width = 12,
      DTOutput("tbl")
    )    
  ),
  fluidRow(
    column(
      width = 12,
      verbatimTextOutput("dbg")
    )    
  )
)

server <- function(input, output, session) {
  my_data <- reactiveVal(dat)
  
  change_values <- function(data, cols) {
    data %>% 
      mutate(
        across(all_of(cols),
               ~ if (is.numeric(.x)) sample(100, 3) else sample(LETTERS, 3))
      )
  }
  
  relevant_data <- reactive(
    my_data() %>% 
      select(starts_with("rel"))
  )
  
  observe({
    my_data(change_values(my_data(), c(paste0("irr_", 1:2),
                                       paste0("rel_", 1:2))))
  }) %>% 
    bindEvent(input$chng_all)
  
  observe({
    my_data(change_values(my_data(), paste0("irr_", 1:2)))
  }) %>% 
    bindEvent(input$chng_irr)
  
  observe({
    my_data(change_values(my_data(), paste0("rel_", 1:2)))
  }) %>% 
    bindEvent(input$chng_rel)
  
  output$tbl <- renderDT(
    datatable(my_data())
  )
  
  output$dbg <- renderPrint({
    glue("Relevant Data Last Changed: {Sys.time()}")
  }) %>% 
    bindEvent(relevant_data())
  
}

shinyApp(ui, server)

Nesta questão Nomeie a saída do pmap no tibble perguntei como nomear corretamente a saída de uma pmapchamada e obtive uma boa resposta, que achei ter entendido.

Porém, quando investiguei mais detalhadamente esse comportamento, não tenho mais tanta certeza de entender os intrínsecos:

library(purrr)
library(tibble)
params <- tibble(nm = LETTERS[1:2], x = 1:2, y = 2:3, z = 1:2)

## 1. setting names on the first argument gives the expected results
params %>%
  mutate(nm = set_names(nm)) %>% 
  pmap(function(nm, x, y, ...) {
    x + y
  }) %>%
  names()
# [1] "A" "B"


## 2. actually it does not need to be the first element
params %>%
  mutate(nm = set_names(nm)) %>% 
  pmap(function(x, y, nm, ...) {
    x + y
  }) %>%
  names()
# [1] "A" "B"

## 3. however, setting names on `x` does not work
params %>%
  mutate(x = set_names(x, nm)) %>% 
  pmap(function(x, y, nm, ...) {
    x + y
  }) %>%
  names()
# NULL

## 4. I thought maybe because they disappear during the addition `+`, but nope
params %>%
  mutate(z = set_names(z, nm)) %>% 
  pmap(function(x, y, nm, ...) {
    x + y
  }) %>%
  names()
# NULL

## 5. Ok maybe a catch all argument `...` prohibits this behaviour, but no
params %>%
  mutate(z = set_names(z, nm)) %>% 
  pmap(function(x, y, nm, z) {
    x + y
  }) %>%
  names()
# NULL

## 6. It seems that names on a character vector work even if not referenced directly
params %>%
  mutate(nm = set_names(nm)) %>% 
  pmap(function(x, y, ...) {
    x + y
  }) %>%
  names()
# [1] "A" "B"

Alguém pode me esclarecer como os nomes são determinados em uma [p]mapchamada?

Quero fazer um loop nas linhas de a tibble, uma coluna deve conter o nome que o slot correspondente deve ter na saída e as outras colunas são os argumentos da função.

Eu sei como resolver isso, mas queria saber se existe alguma possibilidade de fazer a nomenclatura dentro da pmapfunção?

library(purrr)
library(tibble)

params <- tibble(nm = LETTERS[1:2], x = 1:2, y = 2:3)

## this has one addional level of nesting
pmap(params, function(nm, x, y) {
  set_names(list(x + y), nm)
}) # %>% flatten would remove the unnecessary level

## correct format but mixes tidyverse syntax with base syntax
map(split(params, params$nm), ~ .x$x + .x$y)

## correct format & tidyverse syntax but naming must happen **outside**
pmap(params, function(nm, x, y) {
  x + y
}) %>%
  set_names(params$nm)

Resultado esperado como na versão 2 ou 3, com tidyverseestilo, mas sem a necessidade de renomear o resultado posteriormente.

Meta

Eventualmente, quero obter algo assim (esqueça a borda branca em torno disso devido ao recorte):

Restrições

Esses elementos devem estar dentro da seguinte marcação, que não posso alterar facilmente:

<div style="position:absolute;top:15px;right:15px;bottom:15px;left:15px">
  <div style="display:-webkit-flex;display:-ms-flexbox;display:flex;-webkit-flex-direction:column;-ms-flex-direction:column;flex-direction:column;width:100%;height:100%;">
     <div style="position:relative;-webkit-flex:1;-ms-flex:1;flex:1;width:100%;height:100%;">
        <div style="position:absolute;top:0;left:0;right:0;bottom:0;">
          <!-- place elements here -->
        </div>
     </div>
  </div>
</div>

O que eu tentei

<div class="split-container">
  <div class="split-heading">
    <h3>Heading</h3>
  </div>
  <div class="split-content">
    <p>Content</p>
  </div>
</div>

.split-container {
  display: flex;
  height: 100%;
}

.split-heading {
  background-color: rgb(198,89,17);
  color: #fff;
  padding: 0 5px; /* Add padding to the sides */
}

.split-heading > h3 {
  transform: rotate(-90deg);
  transform-origin: bottom right;
}

.split-content {
  flex-grow: 100;
  background-color: rgb(244,176,132);
  color: #fff;
}

Resultado

https://codepen.io/thothal/pen/qBwxEKO

Problemas

• O div do título deve ocupar apenas o espaço necessário (está muito amplo no momento)
• O título deve ser centralizado vertical e horizontalmente
• O conteúdo deve ser centralizado verticalmente