Consider this function:

fx <- function(x) {
  
  sapply(X = x, FUN = function(x) {
    
    if (x > 1) {
      
      NULL
      
    } else (x)
    
  })
  
}

And this data:

set.seed(5)
df_1 <- data.frame(x = replicate(n = 5, expr = runif(n = 5, min = 0, max = 1.7)))

Now, I apply the function to a column of this data:

fx(df_1[,1])

And now, I apply the function in one line.

fx(df_1[1,])

However, when I try to apply this inside reactiveValues ​​I can't get it to work. I think I'm putting it incorrectly inside observeEvent.

I would like that, when the user enters values ​​greater than 1 (either in a row or in a column or both selected), the cell is empty again, just like when typing a text (you can test by writing a text in it and you will see that it becomes empty).

My DT:

library(shiny)
library(shinydashboard)
library(tidyverse)

header <- dashboardHeader(title = "Dash", titleWidth = 250)

sidebar <- dashboardSidebar(sidebarMenu(menuItem(text = "Testar", tabName = "test")))

body <- dashboardBody(
  
  tabItems(
    tabItem(
      tabName = "test",
      titlePanel("Tabela"),
      fluidPage(
        column(
          width = 3, 
          DT::dataTableOutput("my_datatable")
        )
      )
    )
  )
  
)

ui <- dashboardPage(header, sidebar, body)

server <- function(input, output) {
 
  v <- reactiveValues(data = {
    data.frame(y = rep(NA, 30), x = rep(NA, 30))
  })
  
  output$my_datatable <- DT::renderDataTable({
    
    DT::datatable(
      
      data = v$data,
      editable = TRUE,
      rownames = TRUE,
      selection = list(mode = 'none'),
      
      options = list(
        searching = FALSE,
        paging = FALSE,
        ordering = FALSE,
        info = FALSE,
        autoWidth = TRUE
      )
      
    ) 
    
  })
  
  observeEvent(input$my_datatable_cell_edit, {
    
    info = input$my_datatable_cell_edit
    
    i = as.numeric(info$row)
    j = as.numeric(info$col)
    k = as.numeric(info$value)
    
    # converter positivos em negativos (se character, o resultado e NULL)
    if (!is.na(k) & k < 0) {
      
      k <- k * -1
      
    } else (k)
    
    v$data[i, j] <- k
    
  })
  
}

shinyApp(ui, server)

The function I wrote at the beginning of this question I used inside the observeEvent, below this one:

if (!is.na(k) & k < 0) {
  
  k <- k * -1
  
} else (k)

Which works perfectly (and I want to keep it). But, I'd like to add some additional conditions on specific columns and rows, something I haven't been able to do (every time I tried, DT crashed and the app crashed).

CodePudding user response：

The are two issues with your function which result in an error. First, you replace value by NULL so your function returns a list instead of a vector. Second, your function does not account of NAs in the data table, i.e. as you loop over the vector elements each NA element will give rise to an error when checking if (x > 1). Actually you could rewrite your function more concise and without running in these issues like so:

fx <- function(x) {
  x[x > 1] <- NA
  x
}

Note: IMHO there is no need for a function which replaces values in a row or column. As the user enters the values per cell it's sufficient to check whether the inputted value is larger than one and replace it with NA in case it is, i.e. you could use if (k > 1) k <- NA instead.

fx <- function(x) {
  x[x > 1] <- NA
  x
}

library(shiny)
library(shinydashboard)

header <- dashboardHeader(title = "Dash", titleWidth = 250)

sidebar <- dashboardSidebar(sidebarMenu(menuItem(text = "Testar", tabName = "test")))

body <- dashboardBody(
  tabItems(
    tabItem(
      tabName = "test",
      titlePanel("Tabela"),
      fluidPage(
        column(
          width = 3,
          DT::dataTableOutput("my_datatable")
        )
      )
    )
  )
)

ui <- dashboardPage(header, sidebar, body)

server <- function(input, output) {
  v <- reactiveValues(data = {
    data.frame(y = rep(NA, 30), x = rep(NA, 30))
  })

  output$my_datatable <- DT::renderDataTable({
    DT::datatable(
      data = v$data,
      editable = TRUE,
      rownames = TRUE,
      selection = list(mode = "none"),
      options = list(
        searching = FALSE,
        paging = FALSE,
        ordering = FALSE,
        info = FALSE,
        autoWidth = TRUE
      )
    )
  })

  observeEvent(input$my_datatable_cell_edit, {
    info <- input$my_datatable_cell_edit

    i <- as.numeric(info$row)
    j <- as.numeric(info$col)
    k <- as.numeric(info$value)

    if (!is.na(k) && k < 0) {
      k <- k * -1
    }
    
    v$data[i, j] <- k
    
    v$data[i, ] <- fx(v$data[i, ])
  })
}

shinyApp(ui, server)