TarJae's questions

我正在使用 构建一个 Shiny 应用shinyscreenshot。我的应用包含一个“分数”卡，其中有一个 radioGroupButtons 列表，用户可以从中进行选择。radioGroupButtons 在应用中不可见，但是，当我使用 截取屏幕截图时shinyscreenshot，radioGroupButtons 会出现并与数值重叠，导致屏幕截图混乱。

我想在截屏时隐藏 radioGroupButtons。我尝试使用 shinyjs 来切换按钮的可见性，但没有按预期工作。

这是一个最小的可重现示例，演示了我的设置和方法：

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)

我尝试过的方法 自定义 CSS：我添加了一个.hide-for-screenshotCSS 类 display: none !important; 来隐藏元素。该类在截屏前应用，截屏后删除。

使用shinyjs：我正在使用shinyjs::addClass和shinyjs::removeClass来切换.hide-for-screenshot类radioGroupButtons。

问题 尽管在截屏之前添加了hide-for-screenshot类并隐藏了，但它们仍然出现在屏幕截图中。我怀疑这可能是因为没有遵守临时的 CSS 更改，或者延迟时间不足以应用样式。radioGroupButtonsshinyscreenshot

问题 如何确保截取屏幕截图radioGroupButtons时完全隐藏？shinyscreenshot

任何建议或其他方法都将不胜感激！谢谢。

截图如下：

它看起来应该是这样的：

我在工作流中使用 tidymodels 和 xgboost 时遇到问题。在应用包括step_dummy()将分类变量转换为虚拟变量的配方后，我在尝试进行预测时收到以下错误：

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

这是我的代码的简化版本：

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

我怀疑问题与step_dummy()删除原始分类列(A, B, C, D)并用虚拟变量替换有关。但是，工作流程似乎在进行预测时需要原始列。

我该如何解决这个问题并确保预测步骤正确使用创建的虚拟变量step_dummy()？

附加信息：

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()`.

我有两个具有唯一值且长度不等的 tibbles，例如：

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   

我想要得到：

> 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

df1 的 col1 和 df2 的 col2 中的每个相同字符串应并排位于同一行中。例如，如果 col1 和 col2 中的字符串相同，则它们应位于同一行（例如字符串 A）。如果字符串存在于 col1 中但不存在于 col2 中，则它在 col2 中应为 NA，反之亦然。

如有任何建议我将不胜感激。

我正在尝试使用 R 中的包为李克特量表数据创建热图likert，并且我想使用 y 轴标签来包裹它们str_wrap以使它们更具可读性。但是，当我使用str_wrapwith时scale_y_discrete，标签的顺序会更改为字母顺序，而不是保留原始顺序。

MRE 有或没有评论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

当我使用 时scale_y_discrete(labels = str_wrap)，y 轴标签正确换行，但标签的顺序更改为字母顺序。我想保留原始级别中标签的原始顺序。问题：

如何str_wrap在保留原始顺序的同时使用 y 轴标签进行包装ggplot2？

我非常确定该问题是cut由因子到字符类的转换引起的。但是，我无法解决这个问题。

任何有关如何实现这一目标的帮助或指导将不胜感激！

我经常使用 tibbles 并且对它们非常满意。困扰我的唯一重复出现的问题是print(n = ...)每次我想查看超过 10 行时都必须不断添加。我知道我可以使用 将它们转换为数据帧as.data.frame()，但我更愿意print(n=100)为所有小标题设置一个全局打印选项，例如 ，直到我决定更改它。

到目前为止，我一直在做的是

使用print(n=....)

library(dplyr)

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

或使用as.data.frame()

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

或使用自定义函数（类似于 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()

在我们决定更改之前，如何为所有小标题设置全局打印（例如 print(n=20)）选项？

更新：我的期望：

当我做：

mtcars %>% 
  as_tibble()

它应该在设置全局打印（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

我想避免额外的print(n=....), 或print()等行...

没有什么特殊的背景，我只是好奇是否有这方面的考虑：

据我所知，在 R 中，不可能在同一行上包含注释和新代码行，请参阅注释 @Ben Bolker，如本示例所示：

我在2018 年 stackoverflow 和2022 年 stackoverflow中找到了这个。后者使用的自定义函数%com%对我来说不起作用：

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%"

我通常喜欢：

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

我该如何计算col2？

col2col1每次被不同值中断后出现的值都应该递增，例如创建一个每次新序列开始时都会更改的分组变量。

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))

期望的输出：

   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

该包orderInput()中的函数shinyjqui利用六个预定义的 Bootstrap 按钮类来设置其显示的项目的样式。可以使用参数指定这些样式item_class。有关更多详细信息，请参阅文档。

我尝试添加其他类（该orderInput()函数），该函数似乎被设计为仅接受六个预定义的 Bootstrap 按钮类（default、primary、success、info、warning、danger）。

我这可能吗？

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)

更新：这是我想要的图形解释：有以下功能：1.用鼠标调整大小，2.旋转文本。

这是这个的后续问题Drag and drop withshinyjqui to a grid-table。

第一个答案：我正在尝试使项目或按钮带有标签 A resizeable，如此处所述https://yang-tang.github.io/shinyjqui/：“可调整大小：使用鼠标更改元素的大小。”

这可能吗？我已经尝试过该包的通用功能 jqui_sortable以及自定义 JS 代码，如下例所示：

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)