There are the table 1
and table 2
as shown in the script below. I have the following task:
(1) The 1st row of the table 2
should represent a geometric mean of the 1st and 3rd rows of the table 1
;
(2) The 2nd row of the table 2
= a geometric mean of the 2nd and 4th rows of the table 1
.
I would be grateful if someone can help me.
library(shiny)
library(shinydashboard)
library(rhandsontable)
library(data.table)
library(dplyr)
"df1" <- data.table(column1 = as.numeric(c(3,8,3,8)))
"df2" <- data.table(column2 = as.numeric(c(0,0)))
ui <- dashboardPage(
dashboardHeader(title = "Geometric Mean Calculation"),
dashboardSidebar(
menuItem("Calculation", tabName = "calculation",
menuSubItem("Gmean", tabName = "table1"))),
dashboardBody(
tabItems(
tabItem(
tabName = "table1",
column(
"table 1",
width=6,
rHandsontableOutput("Table1")
),
column(
"table 2",
width=6,
rHandsontableOutput("Table2")
)
)
)
)
)
server = function(input, output) {
data <- reactiveValues()
observe({input$recalc
data$`DF1`<- as.data.frame(`df1`)
data$`DF2`<- as.data.frame(`df2`)
})
observe({if(!is.null(input$Table1))
data$`DF1` <- hot_to_r(input$Table1)
})
observe({if(!is.null(input$Table2))
data$`DF2` <- hot_to_r(input$Table2)
})
geometric_mean1<- reactive({with(data$`DF1`,
(column1[1]*column1[3])**(1/2))})
observe({
if(!is.null(geometric_mean1())){
data$`DF2`$column2[1] <- geometric_mean1()[[1]]}
})
geometric_mean2<- reactive({with(data$`DF1`,
(column1[2]*column1[4])**(1/2))})
observe({
if(!is.null(geometric_mean2())){
data$`DF2`$column2[2] <- geometric_mean2()[[1]]}
})
output$Table1 <- renderRHandsontable({
rhandsontable(data$`DF1`)
})
output$Table2 <- renderRHandsontable({
rhandsontable(data$`DF2`)
})
}
shinyApp(ui, server)
You asked about "geometry mean", the general function is
gmean <- function(x, na.rm = FALSE) {
n <- if (na.rm) sum(!is.na(x)) else length(x)
prod(x, na.rm = na.rm)^(1/n)
}
I tweaked the shiny a bit. Some pointers:
as.numeric(c(0,0))
-> c(0,0)
, the 0
is already class numeric
as.data.frame(df1)
-> df1
, since it's already class data.frame
input$recalc
, it's not defined, does/triggers nothingif (!is.null(..))
--> req(..)
, it handles more situations where you don't want the reactive block to fire, and it does it in a way that can cascade to dependent blocks (if (!..)
does not and will needlessly cascade)DF2
; as soon as something is edited (or input$recalc
, whatever that is) in DF1
, then DF2
updateslibrary(shiny)
library(shinydashboard)
library(rhandsontable)
library(data.table)
library(dplyr)
gmean <- function(x, na.rm = FALSE) {
n <- if (na.rm) sum(!is.na(x)) else length(x)
prod(x, na.rm = na.rm)^(1/n)
}
df1 <- data.table(column1 = c(3,8,3,8))
df2 <- data.table(column2 = c(0,0))
ui <- dashboardPage(
dashboardHeader(title = "Geometric Mean Calculation"),
dashboardSidebar(
menuItem("Calculation", tabName = "calculation",
menuSubItem("Gmean", tabName = "table1"))),
dashboardBody(
actionButton("button", label = "Debug!"),
tabItems(
tabItem(
tabName = "table1",
column(
"table 1",
width=6,
rHandsontableOutput("Table1")
),
column(
"table 2",
width=6,
rHandsontableOutput("Table2")
)
)
)
)
)
server = function(input, output) {
data <- reactiveValues()
observe({
req(input$Table1)
data$DF1 <- hot_to_r(input$Table1)
})
observe({
req(input$Table2)
data$DF2 <- hot_to_r(input$Table2)
})
observe({
# input$recalc # ??? no idea
data$DF1 <- df1
# data$DF2 <- df2
})
output$Table1 <- renderRHandsontable({
req(data$DF1)
rhandsontable(data$DF1)
})
output$Table2 <- renderRHandsontable({
req(input$Table1, data$DF1)
data.frame(column2 = c(
gmean(data$DF1$column1[c(1,3)]),
gmean(data$DF1$column1[c(2,4)])
)) |>
rhandsontable()
})
observeEvent(input$button, { browser();1;})
}
shinyApp(ui, server)