inst/shinyapp/alpha_beta_table.R
In gian-asco/test: Longitudinal Analysis of Cancer Evolution (LACE)
# library(shiny)
# library(DT)
# library(stringr)
dt_output = function(title, id) {
#fluidRow(
# column(12, h1(paste0('Table ', sub('.*?([0-9]+)$', '\\1', id), ': ', title)),
# hr(), DTOutput(id)
#))
DTOutput(id, width = "100%")
}
render_dt = function(data, server = TRUE, editable = 'cell', ...) {
#renderDT(data, selection = 'none', server = server, editable = editable, ...)
renderDT(data, server = server)
}
ed_table <- function(id, tb_data, row_basename='row_', session) {
input <- session$input
options(htmlwidgets.TOJSON_ARGS = list(na = 'null'))
tb_data_tmp <- tb_data
newrow_tmp<-as.list(rep(NA,ncol(tb_data_tmp)))
names(newrow_tmp) <- colnames(tb_data_tmp)
tb_data_tmp[nrow(tb_data_tmp)+1,]=newrow_tmp
r_names <- paste0(row_basename,seq_len(nrow(tb_data_tmp)))
r_names[length(r_names)] <- "add row"
rownames(tb_data_tmp) = r_names
js_key <- c(
"table.on('key', function(e, datatable, key, cell, originalEvent){",
" var targetName = originalEvent.target.localName;",
" if(key == 13 && targetName == 'body'){",
" $(cell.node()).trigger('dblclick.dt');",
" }",
"});",
"table.on('keydown', function(e){",
" var keys = [9,13,37,38,39,40];",
" if(e.target.localName == 'input' && keys.indexOf(e.keyCode) > -1){",
" console.log($(e.target).val());",
" if((!$(e.target).val() || $(e.target).val().length === 0 )) {$(e.target).val('ee')};",
" console.log($(e.target).val());",
" $(e.target).trigger('blur');",
" }",
"});",
"table.on('key-focus', function(e, datatable, cell, originalEvent){",
" var targetName = originalEvent.target.localName;",
" var type = originalEvent.type;",
" if(type == 'keydown' && targetName == 'input'){",
" if([9,37,38,39,40].indexOf(originalEvent.keyCode) > -1){",
" $(cell.node()).trigger('dblclick.dt');",
" }",
" }",
"});"
)
isolate({
#session$userData[['ed_table_react_list']][[id]] <- NULL
session$userData[['ed_table_react_list']][[id]] <- datatable(
tb_data_tmp,
selection = "none",
editable = list(target = 'cell', disable = list(columns = c(0))),
callback = JS(js_key),
extensions = c('Scroller',"KeyTable"),#,"Buttons"),
options = list(
keys = T,
#keys = list(blurable= FALSE, editOnFocus = F),
select =list(blurable=F),
#deferRender = F,
scrollY = 100,
scroller = TRUE,
dom = 'Bit' #,
#buttons = c('copy')
)
)
print('create')
print(session$userData[['ed_table_react_list']][[id]]$x$data)
#print('step 0')
#print(ed_table_react_list)
#print(ed_table_react_list[[id]])
#print(ed_table_react_list[[id]]$x$data)
#print('step 0b')
})
#print('step 1')
uis_tmp = list(id)
###
#print ('step a')
# observeEvent(input[[paste0(id,'_cell_edit')]],{
# #browser()
# print(id)
# ed_table_react_list[[id]]$x$data <<- ed_table_react_list[[id]]$x$data[-1]
# }, priority = 1, once = TRUE)
#isolate({
if (!is.null(session$userData$ed_table_react_list_obj$observers[[paste0(id,'cell_edit')]]))
session$userData$ed_table_react_list_obj$observers[[paste0(id,'cell_edit')]]$destroy()
#})
session$userData$ed_table_react_list_obj$observers[[paste0(id,'cell_edit')]]<-observeEvent(input[[paste0(id,'_cell_edit')]],{
print('-------------')
#req(inputs[[paste0(id,'_cell_edit')]])
# print(input[[paste0(id,'_cell_edit')]])
# print('aaa')
#old_e <- inputs[[paste0(id,'_cell_edit_old')]]()
new_e <- isolate(inputs[[paste0(id,'_cell_edit')]]())
print('ccc')
act_e <- isolate(input[[paste0(id,'_cell_edit')]])
print('bbb2')
# print('old_e')
# print(old_e)
# print('act_e')
print(act_e)
# print('new_e')
print(new_e)
if ((new_e$col != act_e$col) | (new_e$row != act_e$row) | (new_e$value != act_e$value)) {
#print((new_e$col != act_e$col) | (new_e$row != act_e$row) | (new_e$value != act_e$value))
#print(new_e$col != act_e$col)
#print(new_e$row != act_e$row)
#print(new_e$value != act_e$value)
#print(typeof(new_e$value))
#print(typeof(act_e$value))
print('made equal')
print(paste('should pre fire', id))
#print(act_e)
#print(new_e)
#inputs[[paste0(id,'_cell_edit_old')]](act_e)
inputs[[paste0(id,'_cell_edit')]](act_e)
#old_e <- inputs[[paste0(id,'_cell_edit_old')]]()
#print(inputs[[paste0(id,'_cell_edit')]]())
}
else
print(paste('should no prefire', id))
})
if (!is.null(session$userData$ed_table_react_list_obj$observers[[paste0(id,'cell_edit_s')]]))
session$userData$ed_table_react_list_obj$observers[[paste0(id,'cell_edit_s')]]$destroy()
session$userData$ed_table_react_list_obj$observers[[paste0(id,'cell_edit_s')]]<-observeEvent(inputs[[paste0(id,'_cell_edit')]](),{
print(paste('pre fire', id))
print(isolate(inputs[[paste0(id,'_cell_edit')]]()))
# if(inputs[[paste0(id,'_cell_edit')]]()$row==-1)
# {
# print('return')
# return()
# }
#
new_e <- isolate(inputs[[paste0(id,'_cell_edit')]]())
act_e <- isolate(input[[paste0(id,'_cell_edit')]])
print(paste('new_e',new_e))
print(paste('act_e',act_e))
#if ((new_e$col == act_e$col) | (new_e$row == act_e$row) | (new_e$value == act_e$value)) {
# print('return')
# return()
#}
#return()
ev <- isolate(inputs[[paste0(id,'_cell_edit')]]())
x <- id
#print(id)
#print('data')
#print(session$userData[['ed_table_react_list']][[id]]$x$data)
mm <- isolate(session$userData[['ed_table_react_list']][[id]]$x$data)
extra_col <- all(mm[[1]] == rownames(mm))
if (is.na(extra_col))
extra_col <- FALSE
if (extra_col){
mm <- mm[-1]
#print('extra_col')
}
#print('mm')
#print(mm)
#print('step 2')
#print(mm)
#browser()
if(length(as.character(ev$value))>=1)
if(str_length(as.character(ev$value))>=1) {
if (input[[paste0(id,'_cell_edit')]]$row == nrow(mm)) {
#print('step 3a')
for (j in seq(1, ncol(mm))) {
if (is.na(mm[nrow(mm),j]))
mm[nrow(mm),j] <- "0.001"
}
newrow<-as.list(rep(NA,ncol(mm)))
#names(newrow) <- colnames(mm)
df_newrow <-data.frame(newrow)
names(df_newrow) <- colnames(mm)
mm <- rbind(mm, df_newrow)
rownames(mm)[nrow(mm)] <- "add row"
}
}
#print('step 3')
r_names <- paste0(row_basename, seq(1:nrow(mm)))
r_names[length(r_names)] <- "add row"
rownames(mm) <- r_names
val_tmp<-isolate(ev)
if(length(as.character(ev$value))>=1)
if (str_length(as.character(ev$value))==0)
val_tmp$value=NA
#print('step 4')
if (is.na(mm[val_tmp$row, val_tmp$col]))
mm[val_tmp$row, val_tmp$col]=val_tmp$value
mm <- editData(mm, val_tmp, proxy = id, resetPaging = FALSE, rownames=TRUE )
for (i in seq(1:max(nrow(mm)-1,1))) { # i = val_tmp$row
canc <-0
for (j in seq(1, ncol(mm))) {
if (is.na(mm[i,j])) {
canc <- canc+1
}
}
#print("2222222222222222222222")
#print(canc == ncol(mm) && i<nrow(mm))
#print(nrow(mm))
if(canc == ncol(mm) && i<nrow(mm)) {
if (nrow(mm)>2) {
mm_pre <- NULL
mm_post <- NULL
if (i>1)
mm_pre <- mm[1:i-1,]
if (i<nrow(mm))
mm_post <- mm[(i+1):nrow(mm),]
mm <- rbind(mm_pre, mm_post)
r_names <- paste0(row_basename, seq(1:nrow(mm)))
r_names[length(r_names)] <- "add row"
rownames(mm) <- r_names
break
}
else
{
for (j in seq(1, ncol(mm))) {
if (is.na(mm[nrow(mm),j]))
mm[1,j] <- "0.001"
}
}
}
}
# if(is.na(mm[val_tmp$row, val_tmp$col]))
# mm[val_tmp$row, val_tmp$col]=NA
proxy<-dataTableProxy(id)
#print('mm')
#print(mm)
session$userData[['ed_table_react_list']][[id]]$x$data <- editData(mm, val_tmp, resetPaging = FALSE, rownames=TRUE )
replaceData(proxy, mm)
print('update')
print(isolate(session$userData[['ed_table_react_list']][[id]]$x$data))
#print(proxy)
#session$userData[['ed_table_react_list']][[id]]$x$data
#print(id)
#print(ed_table_react_list[[id]]$x$data)
#print('fine')
}, ignoreInit = T)
###
return(isolate(session$userData[['ed_table_react_list']][[id]]))
}
# d1 = iris[1:3,1:4]
#
# shinyApp(
# ui = fluidPage(
# title = 'Double-click to edit table cells',
# dt_output('prova', 'mytable'),
# dt_output('prova', 'mytable2'),
# DTOutput('inf_alpha')
# ),
#
# server = function(input, output, session) {
#
# empty_table <- data.frame(matrix(ncol = 2, nrow = 0))
# colnames(empty_table) <- c('T1', 'T2')
# ed_table_alpha <- ed_table('inf_alpha', empty_table, 'alpha_', session)
# output$inf_alpha <- render_dt(ed_table_alpha)
#
# d1_tmp <-d1
# rownames(d1_tmp) = c('alpha_1','alpha_2','alpha_3')
# newrow2<-as.list(rep(NA,ncol(d1_tmp)))
# names(newrow2) <- colnames(d1_tmp)
# d1_tmp[3,]=newrow2
#
# #options(DT.options = list(pageLength = 8))
# ed_table_1 <- ed_table('mytable', d1, 'beta___', session)
# ed_table_2 <- ed_table('mytable2', d1, 'alpha_', session)
# output$mytable <- render_dt(ed_table_1)
# output$mytable2 <- render_dt(ed_table_2)
# #print(ed_table_1)
# }
# )
gian-asco/test documentation built on April 11, 2022, 12:05 a.m.
R Package Documentation
Browse R Packages
We want your feedback!
Note that we can't provide technical support on individual packages. You should contact the package authors for that.
# library(shiny)
# library(DT)
# library(stringr)
dt_output = function(title, id) {
#fluidRow(
# column(12, h1(paste0('Table ', sub('.*?([0-9]+)$', '\\1', id), ': ', title)),
# hr(), DTOutput(id)
#))
DTOutput(id, width = "100%")
}
render_dt = function(data, server = TRUE, editable = 'cell', ...) {
#renderDT(data, selection = 'none', server = server, editable = editable, ...)
renderDT(data, server = server)
}
ed_table <- function(id, tb_data, row_basename='row_', session) {
input <- session$input
options(htmlwidgets.TOJSON_ARGS = list(na = 'null'))
tb_data_tmp <- tb_data
newrow_tmp<-as.list(rep(NA,ncol(tb_data_tmp)))
names(newrow_tmp) <- colnames(tb_data_tmp)
tb_data_tmp[nrow(tb_data_tmp)+1,]=newrow_tmp
r_names <- paste0(row_basename,seq_len(nrow(tb_data_tmp)))
r_names[length(r_names)] <- "add row"
rownames(tb_data_tmp) = r_names
js_key <- c(
"table.on('key', function(e, datatable, key, cell, originalEvent){",
" var targetName = originalEvent.target.localName;",
" if(key == 13 && targetName == 'body'){",
" $(cell.node()).trigger('dblclick.dt');",
" }",
"});",
"table.on('keydown', function(e){",
" var keys = [9,13,37,38,39,40];",
" if(e.target.localName == 'input' && keys.indexOf(e.keyCode) > -1){",
" console.log($(e.target).val());",
" if((!$(e.target).val() || $(e.target).val().length === 0 )) {$(e.target).val('ee')};",
" console.log($(e.target).val());",
" $(e.target).trigger('blur');",
" }",
"});",
"table.on('key-focus', function(e, datatable, cell, originalEvent){",
" var targetName = originalEvent.target.localName;",
" var type = originalEvent.type;",
" if(type == 'keydown' && targetName == 'input'){",
" if([9,37,38,39,40].indexOf(originalEvent.keyCode) > -1){",
" $(cell.node()).trigger('dblclick.dt');",
" }",
" }",
"});"
)
isolate({
#session$userData[['ed_table_react_list']][[id]] <- NULL
session$userData[['ed_table_react_list']][[id]] <- datatable(
tb_data_tmp,
selection = "none",
editable = list(target = 'cell', disable = list(columns = c(0))),
callback = JS(js_key),
extensions = c('Scroller',"KeyTable"),#,"Buttons"),
options = list(
keys = T,
#keys = list(blurable= FALSE, editOnFocus = F),
select =list(blurable=F),
#deferRender = F,
scrollY = 100,
scroller = TRUE,
dom = 'Bit' #,
#buttons = c('copy')
)
)
print('create')
print(session$userData[['ed_table_react_list']][[id]]$x$data)
#print('step 0')
#print(ed_table_react_list)
#print(ed_table_react_list[[id]])
#print(ed_table_react_list[[id]]$x$data)
#print('step 0b')
})
#print('step 1')
uis_tmp = list(id)
###
#print ('step a')
# observeEvent(input[[paste0(id,'_cell_edit')]],{
# #browser()
# print(id)
# ed_table_react_list[[id]]$x$data <<- ed_table_react_list[[id]]$x$data[-1]
# }, priority = 1, once = TRUE)
#isolate({
if (!is.null(session$userData$ed_table_react_list_obj$observers[[paste0(id,'cell_edit')]]))
session$userData$ed_table_react_list_obj$observers[[paste0(id,'cell_edit')]]$destroy()
#})
session$userData$ed_table_react_list_obj$observers[[paste0(id,'cell_edit')]]<-observeEvent(input[[paste0(id,'_cell_edit')]],{
print('-------------')
#req(inputs[[paste0(id,'_cell_edit')]])
# print(input[[paste0(id,'_cell_edit')]])
# print('aaa')
#old_e <- inputs[[paste0(id,'_cell_edit_old')]]()
new_e <- isolate(inputs[[paste0(id,'_cell_edit')]]())
print('ccc')
act_e <- isolate(input[[paste0(id,'_cell_edit')]])
print('bbb2')
# print('old_e')
# print(old_e)
# print('act_e')
print(act_e)
# print('new_e')
print(new_e)
if ((new_e$col != act_e$col) | (new_e$row != act_e$row) | (new_e$value != act_e$value)) {
#print((new_e$col != act_e$col) | (new_e$row != act_e$row) | (new_e$value != act_e$value))
#print(new_e$col != act_e$col)
#print(new_e$row != act_e$row)
#print(new_e$value != act_e$value)
#print(typeof(new_e$value))
#print(typeof(act_e$value))
print('made equal')
print(paste('should pre fire', id))
#print(act_e)
#print(new_e)
#inputs[[paste0(id,'_cell_edit_old')]](act_e)
inputs[[paste0(id,'_cell_edit')]](act_e)
#old_e <- inputs[[paste0(id,'_cell_edit_old')]]()
#print(inputs[[paste0(id,'_cell_edit')]]())
}
else
print(paste('should no prefire', id))
})
if (!is.null(session$userData$ed_table_react_list_obj$observers[[paste0(id,'cell_edit_s')]]))
session$userData$ed_table_react_list_obj$observers[[paste0(id,'cell_edit_s')]]$destroy()
session$userData$ed_table_react_list_obj$observers[[paste0(id,'cell_edit_s')]]<-observeEvent(inputs[[paste0(id,'_cell_edit')]](),{
print(paste('pre fire', id))
print(isolate(inputs[[paste0(id,'_cell_edit')]]()))
# if(inputs[[paste0(id,'_cell_edit')]]()$row==-1)
# {
# print('return')
# return()
# }
#
new_e <- isolate(inputs[[paste0(id,'_cell_edit')]]())
act_e <- isolate(input[[paste0(id,'_cell_edit')]])
print(paste('new_e',new_e))
print(paste('act_e',act_e))
#if ((new_e$col == act_e$col) | (new_e$row == act_e$row) | (new_e$value == act_e$value)) {
# print('return')
# return()
#}
#return()
ev <- isolate(inputs[[paste0(id,'_cell_edit')]]())
x <- id
#print(id)
#print('data')
#print(session$userData[['ed_table_react_list']][[id]]$x$data)
mm <- isolate(session$userData[['ed_table_react_list']][[id]]$x$data)
extra_col <- all(mm[[1]] == rownames(mm))
if (is.na(extra_col))
extra_col <- FALSE
if (extra_col){
mm <- mm[-1]
#print('extra_col')
}
#print('mm')
#print(mm)
#print('step 2')
#print(mm)
#browser()
if(length(as.character(ev$value))>=1)
if(str_length(as.character(ev$value))>=1) {
if (input[[paste0(id,'_cell_edit')]]$row == nrow(mm)) {
#print('step 3a')
for (j in seq(1, ncol(mm))) {
if (is.na(mm[nrow(mm),j]))
mm[nrow(mm),j] <- "0.001"
}
newrow<-as.list(rep(NA,ncol(mm)))
#names(newrow) <- colnames(mm)
df_newrow <-data.frame(newrow)
names(df_newrow) <- colnames(mm)
mm <- rbind(mm, df_newrow)
rownames(mm)[nrow(mm)] <- "add row"
}
}
#print('step 3')
r_names <- paste0(row_basename, seq(1:nrow(mm)))
r_names[length(r_names)] <- "add row"
rownames(mm) <- r_names
val_tmp<-isolate(ev)
if(length(as.character(ev$value))>=1)
if (str_length(as.character(ev$value))==0)
val_tmp$value=NA
#print('step 4')
if (is.na(mm[val_tmp$row, val_tmp$col]))
mm[val_tmp$row, val_tmp$col]=val_tmp$value
mm <- editData(mm, val_tmp, proxy = id, resetPaging = FALSE, rownames=TRUE )
for (i in seq(1:max(nrow(mm)-1,1))) { # i = val_tmp$row
canc <-0
for (j in seq(1, ncol(mm))) {
if (is.na(mm[i,j])) {
canc <- canc+1
}
}
#print("2222222222222222222222")
#print(canc == ncol(mm) && i<nrow(mm))
#print(nrow(mm))
if(canc == ncol(mm) && i<nrow(mm)) {
if (nrow(mm)>2) {
mm_pre <- NULL
mm_post <- NULL
if (i>1)
mm_pre <- mm[1:i-1,]
if (i<nrow(mm))
mm_post <- mm[(i+1):nrow(mm),]
mm <- rbind(mm_pre, mm_post)
r_names <- paste0(row_basename, seq(1:nrow(mm)))
r_names[length(r_names)] <- "add row"
rownames(mm) <- r_names
break
}
else
{
for (j in seq(1, ncol(mm))) {
if (is.na(mm[nrow(mm),j]))
mm[1,j] <- "0.001"
}
}
}
}
# if(is.na(mm[val_tmp$row, val_tmp$col]))
# mm[val_tmp$row, val_tmp$col]=NA
proxy<-dataTableProxy(id)
#print('mm')
#print(mm)
session$userData[['ed_table_react_list']][[id]]$x$data <- editData(mm, val_tmp, resetPaging = FALSE, rownames=TRUE )
replaceData(proxy, mm)
print('update')
print(isolate(session$userData[['ed_table_react_list']][[id]]$x$data))
#print(proxy)
#session$userData[['ed_table_react_list']][[id]]$x$data
#print(id)
#print(ed_table_react_list[[id]]$x$data)
#print('fine')
}, ignoreInit = T)
###
return(isolate(session$userData[['ed_table_react_list']][[id]]))
}
# d1 = iris[1:3,1:4]
#
# shinyApp(
# ui = fluidPage(
# title = 'Double-click to edit table cells',
# dt_output('prova', 'mytable'),
# dt_output('prova', 'mytable2'),
# DTOutput('inf_alpha')
# ),
#
# server = function(input, output, session) {
#
# empty_table <- data.frame(matrix(ncol = 2, nrow = 0))
# colnames(empty_table) <- c('T1', 'T2')
# ed_table_alpha <- ed_table('inf_alpha', empty_table, 'alpha_', session)
# output$inf_alpha <- render_dt(ed_table_alpha)
#
# d1_tmp <-d1
# rownames(d1_tmp) = c('alpha_1','alpha_2','alpha_3')
# newrow2<-as.list(rep(NA,ncol(d1_tmp)))
# names(newrow2) <- colnames(d1_tmp)
# d1_tmp[3,]=newrow2
#
# #options(DT.options = list(pageLength = 8))
# ed_table_1 <- ed_table('mytable', d1, 'beta___', session)
# ed_table_2 <- ed_table('mytable2', d1, 'alpha_', session)
# output$mytable <- render_dt(ed_table_1)
# output$mytable2 <- render_dt(ed_table_2)
# #print(ed_table_1)
# }
# )
R Package Documentation
Browse R Packages
We want your feedback!
Note that we can't provide technical support on individual packages. You should contact the package authors for that.
Embedding an R snippet on your website
Add the following code to your website.
For more information on customizing the embed code, read Embedding Snippets.