#--------NEW COLUMN------------------------------
addNewColModal <- function(errMssg=NULL, init=TRUE, treatAsSelect='string') {
#log.val(treatAsSelect)
if(init){
is.Non.Blank.Name(FALSE)
is.Non.Blank.Value(FALSE)
}
doOk<-"shinyjs.triggerButtonOnEnter(event,\"commitNewCol\")"
ppscriptChoices<-unique(preProcScriptDB$attrs$scriptName)
colChoices<-names(aux$colChoiceSet)
colChoices<-unique(colChoices)
choices<-list(
' a single character string'='string','a single number'='number','a vector'='expression',
'a matrix of points'='points')
if(length(ppscriptChoices)>0){
choices<-c(choices,list('using a preprocessing script'='script'))
}
if(length(aux$colChoiceSet)>0){
choices<-c(choices,list('using a choice set'='choiceSet'))
}
modalDialog(
size='l',
onkeypress=doOk,
span('Enter both a name for the new column and a value for its entries'),
textInput("modalAttrName", "Enter the name for the new column"),
div( class='ptR2',id='modalColTreatAsDiv',
awesomeRadio('modalColTreatAs', 'Initialize Column Values as ',
choices = choices ,
inline = TRUE,
selected=treatAsSelect
)
),
div(
textInput("modalAttrValue", "Enter an entry value for the new column" )
),
# pick from preproc list
if(length(ppscriptChoices)>0){
div( class='ptR2', #awesomeRadio
pickerInput('modalColPreProcScript', 'Set entry values using the script:',
choices = ppscriptChoices,
inline = FALSE
)
)
} else {
NULL
},
if(length(aux$colChoiceSet)>0){
div( style=paste0("display:inline-block;"),
div(style="float:left;",pickerInput('modalColChooserSet', 'Choiceset:',
choices = colChoices,
inline = FALSE
)),
div(style="float:right;",pickerInput('modalColChooserValue', 'Choice value:',
choices = aux$colChoiceSet[[1]],
inline = FALSE
))
)
} else {
NULL
},
if(!is.null(errMssg)){
div(tags$b(errMssg, style = "color: red;"))
},
footer = tagList(
modalButton("Cancel"),
actionButton("commitNewCol", "Commit")
)
)
}
is.Non.Blank.Name<-reactiveVal(FALSE)
is.Non.Blank.Value<-reactiveVal(FALSE)
observeEvent(input$modalAttrName,{
str<-input$modalAttrName
if(goodRName(str) && !(str %in% c( names(getTib()), 'svgPanel', 'RPanel' ) )){
is.Non.Blank.Name(TRUE)
# showElement('modalColTreatAsDiv')
} else {
is.Non.Blank.Name(FALSE)
}
# is.Non.Blank.Name(nchar(str)>0)
})
observeEvent(input$modalAttrValue,{
str<-input$modalAttrValue
is.Non.Blank.Value(nchar(str)>0)
})
observeEvent(input$modalColChooserSet,{
name<-input$modalColChooserSet
choices<-getChoiceSetElements(name)
updatePickerInput(session,inputId ="modalColChooserValue", choices=choices, selected=choices[[1]])
})
observeEvent(c(is.Non.Blank.Name(),input$modalColTreatAs, is.Non.Blank.Value() , input$modalAttrValue),{
if( is.Non.Blank.Name()){
showElement('modalColTreatAsDiv')
if( !(input$modalColTreatAs %in% c('string','number','expression')) ||
(is.Non.Blank.Value() && input$modalColTreatAs!='number') ||
isNumericString(input$modalAttrValue)
){
showElement('commitNewCol')
} else {
hideElement('commitNewCol')
}
if(input$modalColTreatAs=='points'){
hideElement('modalAttrValue')
hideElement('modalColPreProcScript')
hideElement('modalColChooserSet')
hideElement('modalColChooserValue')
} else if (input$modalColTreatAs=='script') {
hideElement('modalAttrValue')
showElement('modalColPreProcScript')
hideElement('modalColChooserSet')
hideElement('modalColChooserValue')
} else if (input$modalColTreatAs=='choiceSet') {
hideElement('modalAttrValue')
hideElement('modalColPreProcScript')
showElement('modalColChooserSet')
showElement('modalColChooserValue')
} else {
showElement('modalAttrValue')
hideElement('modalColPreProcScript')
hideElement('modalColChooserSet')
hideElement('modalColChooserValue')
}
} else {
hideElement('modalColTreatAsDiv')
hideElement('modalAttrValue')
hideElement('modalColPreProcScript')
hideElement('modalColChooserSet')
hideElement('modalColChooserValue')
hideElement('commitNewCol')
}
})
# observeEvent(input$cancel, {
# # set as blank? modalAttrValue
# hideElement('modalAttrValue')
# hideElement('modalColPreProcScript')
# hideElement('modalColChooserSet')
# hideElement('modalColChooserValue')
# removeModal() #close dialog
# })
observeEvent(input$commitNewCol, {
badExpr<-function(txt){
rtv<-TRUE
tryCatch({
eval(parse(text=txt))
rtv<-FALSE
},
error = function(e) {})
rtv
}
treatAs<-input$modalColTreatAs
newVal<-input$modalAttrValue
#checks
if(!grepl(pattern = "^[[:alpha:]]", input$modalAttrName)){
#if(!goodRName(input$modalAttrName)){
# check name syntax
showModal(addNewColModal( errMssg="Invalid Column Name: must begin with a character", treatAsSelect=treatAs) )
} else if( input$modalAttrName %in% names(getTib()) ){
# check name uniqueness
showModal(addNewColModal( errMssg="Invalid Column Name: this name is already taken!", treatAsSelect=treatAs) )
} else if(
(!(treatAs %in% c('script', 'points', 'choiceSet' ))) &&
(!grepl(pattern = "^[[:graph:]]", input$modalAttrValue))
){
# check value is printable
showModal(addNewColModal( errMssg="Invalid Column Value: must begin with printable character other than space", treatAsSelect=treatAs) )
} else if( treatAs=='expression' && badExpr( input$modalAttrValue )==TRUE ){
showModal(addNewColModal( errMssg="Unable to evaluate expression", treatAsSelect=treatAs) )
} else { # checks passed
#add name to tib
newPtDefs<-getPtDefs()
newColName<-input$modalAttrName
if(treatAs=='script'){ # apply script sequentially to newPtDefs
# extract onNewRowScript
script_Name<-input$modalColPreProcScript
tb<-filter(preProcScriptDB$attrs, scriptName==script_Name)
scripts<-unlist(tb$script)
names(scripts)<-tb$cmd
txt<-scripts['onNewRow']
# signature of onNewRowScript is pt, context, WH, keys
# But keys, pt, WH, are likey IRRELEVANT
#One strategy
tryCatch({
# 1. newPtDefs<-getPtDefs()
# 2.
tibs<-newPtDefs$tib
# 3.
tib<-tibs[[getAssetName()]]
# 4.
tib[[newColName]]<-NA
tibs[[getAssetName()]]<-tib
# 5.
context<-list(
name=getAssetName(),
column=ncol(tib),
row=1,
tibs=tibs
)
#6.
ppenv<-list(
setAttrValue=setAttrValue,
getAttrValue=function(){NA},
getLastRow=getLastRow,
replaceLastRow=replaceLastRow,
appendLastRow=appendLastRow,
appendAttrValues=appendAttrValues,
context=context,
keys=list(altKey=FALSE, shiftKey=FALSE, ctrlKey=FALSE, metaKey=FALSE, keycode=NULL)
)
for(rowIndex in 1:nrow(tib)){
ppenv$context$row<-rowIndex
ppenv$context$tibs<-tibs
tibs<-eval(parse(text=txt), ppenv )
#ppenv$tibs<-tibs
}
# 7. check if tibs is valid
validateTibLists(getPtDefs()$tib, tibs)
newPtDefs$tib<-tibs
sender='cmd.add.column'
#set the column to use specified script
setPreProcScriptName(tab_Id=getTibTabId(), tib_Name= getAssetName(), column_Name=newColName, script_Name=script_Name)
}, error=function(e){
e<-c('preproErr',e$message)
err<-paste(unlist(e), collapse="\n", sep="\n")
shinyalert("preproc new column Error",err, type="error") # may want to put this in a scrollable modal
})
} else { #not scripting
if(treatAs=='choiceSet'){
newVal<-input$modalColChooserValue
# restrict that value is restiricted to this list
colSet_Name<-input$modalColChooserSet
#To do: perform additional checks !!!
log.val(colSet_Name)
# populate widgetDB
db<-widgetDB()
pageId<- input$pages
tibName<-getAssetName()
columnName<-input$modalAttrName
db1<-db
db2<-tibble_row( tabId=pageId, name=tibName, column=columnName,
type='choiceSet' , minVal=NA, maxVal=NA, step=1, selectedWidget=colSet_Name)
db3<-bind_rows(db1,db2)
widgetDB(db3)
}
if(treatAs=='number'){
newVal<-as.numeric(newVal)
} else if ( treatAs=='points'){
newVal<-list(matrix(0,2,0))
} else if ( treatAs=='expression'){
newVal<-list(eval(parse(text=newVal))) # to do: validate!!!
}
# newVal is ready to insert
newPtDefs$tib[[getAssetName()]]<-add_column(newPtDefs$tib[[getAssetName()]],
!!(newColName):=newVal )
}
# updateAce and set selection to this column
sender<-'cmd.add.column'
updateAceExtDef(newPtDefs, sender=sender, selector=list( columnName = newColName ) )
removeModal() #close dialog
}
})
Add the following code to your website.
For more information on customizing the embed code, read Embedding Snippets.