diff --git a/DESCRIPTION b/DESCRIPTION index 42057b27..8589528e 100644 --- a/DESCRIPTION +++ b/DESCRIPTION @@ -1,8 +1,8 @@ Package: pointR Type: Package -Date: 2019-12-30 +Date: 2021-08-20 Title: pointR -Version: 0.4.1.11 +Version: 0.5.3 Author: M.S.Legrand Maintainer: M.S.Legrand Description: pointR is a shiny-based IDE for svgR @@ -20,6 +20,7 @@ Imports: shinyDMDMenu, shinyFiles, shinythemes, + shinyalert, colourpicker, shinyWidgets, bsplus, @@ -29,7 +30,7 @@ Imports: shinyjqui Suggests: testthat -RoxygenNote: 6.1.1 +RoxygenNote: 7.1.1 Remotes: mslegrand/shinyDMDMenu, mslegrand/svgR, diff --git a/LICENSE.txt b/LICENSE.txt index a1b0d47c..61f0c97d 100644 --- a/LICENSE.txt +++ b/LICENSE.txt @@ -1,6 +1,6 @@ NOTICE -Copyright (c) 2020 M. S. Legrand. All rights reserved +Copyright (c) 2021 M. S. Legrand. All rights reserved The pointR package as a whole is distributed under the GPL-3 License, GNU GENERAL PUBLIC LICENSE version 3, see below. diff --git a/README.md b/README.md index 59a835b7..72b2edcf 100644 --- a/README.md +++ b/README.md @@ -1,43 +1,61 @@ -# pointR -**pointR** is an R package providing a *shiny-based* minimalist ide for R scripting using svgR -- ***Videos on pointR*** can be found at http://mslegrand.github.io/pointRmedia/. +## Installation + +For a full featured install go to http://mslegrand.github.io/pointR/. There you will find package installers for linux, mac and windows. + +## pointR and ptR + +- **pointR** is an R package providing a *shiny-based* minimalist IDE for R scripting using svgR. **pointR** is primarly written in R, with a little bit of javascript for seasoning. +- **ptR** is an **Electron** wrapper around **pointR**. +- Using **Electron** + - Removes potential hiccups by removing and dependency on the local browser + - Provides independent windows for help + - Provides an integrated approach for building **shiny custom inputs** + - ***Related information*** can be found at http://mslegrand.github.io/svgR/. - ***Rambling thoughts*** can be found on the wiki at https://github.com/mslegrand/pointR/wiki -## Some Points on PointR +## Some Points on pointR - pointR is a shiny server application - pointR uses the ACE editor for coding - pointR is intended to ease the writing of R scripts using svgR. - pointR is an attempt to bridge the gap between coding and point&click. - svgR bridges the gap between R and SVG -## Try Out -- runGitHub("pointR", "mslegrand") - -# Installation -- install.packages("devtools") -- library(devtools) -- install_github("shiny", "rstudio") -- install_github("shinyAce", "trestletech") -- install_github("shinyjs", "daattali") -- install_github("svgR", "mslegrand") - -# Reporting issues +## Some Points on ptR +- ptR is an Electron wrapper around pointR +- ptR is javascript (since Electron is) +- Electron is required for full functionality (such as building shiny input controls) + + + +## Building from Source + +0. Warning, you might find this painful. +1. [Download pointR](https://github.com/mslegrand/pointR) and build the **pointR** library +2. [Download ptR](https://github.com/mslegrand/ptR) and place in a folder (like pointR-electron/ptRMigrate) +3. cd to ptRMigrate and edit script ./build/mklib.sh to copy the ptR lib to 2 locations (for testing & production) +4. Install node.js, npm, electon +5. from terminal run **npm start** + +**NOTE** I've built both on linux and mac machines, but not windows. + + +## Reporting issues Please report any bugs/issue in the [Github Issue tracker](https://github.com/mslegrand/pointR) #Contributing If you wish to contribute to the pointR project, now is the time. Thanks. -# Caution +## Caution To quote from TrestleTech: *As with any online application, it is a genuinely bad idea to allow arbitrary users to execute code on your server.* **BE CAREFUL!!** -# Licensing +## Licensing NOTICE -Copyright (c) 2018 M. S. Legrand. All rights reserved +Copyright (c) 2020 M. S. Legrand. All rights reserved The pointR package as a whole is distributed under the GPL-3 License, GNU GENERAL PUBLIC LICENSE version 3, see below. diff --git a/inst/App/fileIO/dndSnippetLoader.R b/inst/App/fileIO/dndSnippetLoader.R index 61a01706..7d811232 100644 --- a/inst/App/fileIO/dndSnippetLoader.R +++ b/inst/App/fileIO/dndSnippetLoader.R @@ -21,9 +21,11 @@ dripplets2Rmd<-function( drps ){ unlist(str_split(drps, '\n'))->drps indx<-m[2,] drps[indx]<-paste( - "temp$root$setAttr('width',480)", - "temp$root$setAttr('height',320)", - "temp$root$setAttr('viewBox','0 0 48 32')", + "temp$root$setAttr('width',48)", + "temp$root$setAttr('height',32)", + # "temp$root$setAttr('viewBox','0 0 48 32')", + "temp$root$setAttr('stroke','#00FFFF')", + "temp$root$setAttr('fill','#00FFFF')", "temp$root$prependChildren( svgR:::use(filter=svgR:::filter( filterUnits='userSpaceOnUse', svgR:::feFlood(flood.color='black') ) ) )", @@ -35,7 +37,7 @@ dripplets2Rmd<-function( drps ){ drps<-str_replace(drps, "\noutput: dnd_snippet", "\noutput: html_document") drps<-str_replace_all(drps, "POPUP\\s*\n```\n(.+)\n```", "### \\1") drps<-str_replace_all(drps, "\nSNIPPET\\s*","\n") - drps<-str_replace_all(drps, "\nSVGR\\s*\n```\n", '\n\n```\\{r, echo=FALSE, results=\'asis\'\\}\n') + drps<-str_replace_all(drps, "\nSVGR\\s*\n```\n", '\n\n```\\{r, echo=FALSE, results=\'asis\'\\}\nWH=c(48,32)\n') drps } @@ -95,7 +97,15 @@ extractDripplet<-function(dr ){ if(all(m>0)){ rtv<-tt rtv<-tryCatch({ - svg<-as.character(eval(parse(text=tt['SVGR']), new.env())) + # svg<-as.character(eval(parse(text=tt['SVGR']), new.env())) + # svg<-eval(parse(text=tt['SVGR']), new.env()) + svg<-eval(parse(text=tt['SVGR']), list(WH=c(48,32))) + svg$root$setAttr('stroke','#00FFFF') + svg$root$setAttr('fill','#00FFFF') + svg$root$setAttr('width',48) + svg$root$setAttr('height',32) + #set width, height??? + svg<-as.character(svg) rtv["SVGR"]<-svg names(rtv)<-c('hint','snip','logo')[m] rtv @@ -119,10 +129,20 @@ dripplets2List2<-function(drps){ rtv<-extractDripplet(dr) rtv }) - + s.upper<-function(s){ + paste(toupper(substring(s, 1, 1)), substring(s, 2), + sep = "", collapse = " ") + } + drps<-lapply(drps, function(dr){ + dr['snip']<-gsub("\\```","```" , dr['snip']) + dr + }) if(!is.null(editOption$currentProjectName)){ + cname<-sub('\\.pprj$','', editOption$currentProjectName) + Cname<-s.upper(cname) drps<-lapply(drps, function(dr){ - dr['snip']<-gsub('@projectName@', editOption$currentProjectName, dr['snip']) + dr['snip']<-gsub('@projectName@', cname , dr['snip']) + dr['snip']<-gsub('@ProjectName@', Cname , dr['snip']) dr }) } diff --git a/inst/App/fileIO/genShinyFilesOpenButtons.R b/inst/App/fileIO/genShinyFilesOpenButtons.R index b9bfcc2f..8ef87bbf 100644 --- a/inst/App/fileIO/genShinyFilesOpenButtons.R +++ b/inst/App/fileIO/genShinyFilesOpenButtons.R @@ -9,6 +9,7 @@ UIGenShinyOpenFilesButtons<-function(){ shinyFilesButton("buttonFileOpen", label="", title="Open File", multiple=FALSE, class='hiddenButton'), shinyFilesButton("buttonFileOpenProject", label="", title="Select Project to Open", multiple=FALSE, class='hiddenButton'), + shinyFilesButton("buttonChoiceSetImport", label="", title="Import Choice Set", multiple=FALSE, class='hiddenButton'), shinyFilesButton("buttonSnippetImport", label="", title="Import Snippets", multiple=FALSE, class='hiddenButton'), shinyFilesButton("buttonDnippetImport", label="", title="Import Dnippets", multiple=FALSE, class='hiddenButton'), shinyFilesButton("buttonPreProcPtImport", label="", title="Import PreProcessors for points", multiple=FALSE, class='hiddenButton'), diff --git a/inst/App/fileIO/genShinyFilesSaveButtons.R b/inst/App/fileIO/genShinyFilesSaveButtons.R index dafac8ca..2e0ca57f 100644 --- a/inst/App/fileIO/genShinyFilesSaveButtons.R +++ b/inst/App/fileIO/genShinyFilesSaveButtons.R @@ -4,7 +4,7 @@ saveButtonFileNames<-setNames(paste0('buttonFileSave', extMode.TB$ext), extMode. UIGenShinySaveFilesButtons<-function(){ tt<-setNames(as.list(extMode.TB$ext),extMode.TB$mode) fileTypes<-lapply(tt, function(x){ - xx<-c(x,tt[tt!=x]) + xx<-c(x,tt[tt!=x]) #move the prefered mode to the top setNames(as.list(xx),xx) }) tmp<-lapply(extMode.TB$mode, function(mode){ diff --git a/inst/App/fileIO/observeRequestStartUp.R b/inst/App/fileIO/observeRequestStartUp.R index 2ea9fd74..759149b3 100644 --- a/inst/App/fileIO/observeRequestStartUp.R +++ b/inst/App/fileIO/observeRequestStartUp.R @@ -11,11 +11,21 @@ observeEvent(trigger$startup, { } else { } - disableDMDM( - session, - menuBarId="editNavBar", - entry="customControl" - ) + updateNewProjectMenu(session) + updateRemoveTemplateMenu(session) + resetWatcher() + readAuxChoices() log.fout(startup) }, priority=100) + + +resetWatcher<-reactive({ + if(usingElectron){ + allFilePaths<-getAllNamedFiles()$filePath + allFilePaths<-normalizePath(allFilePaths) + # cat('pointR::resetWatcher: allFilePaths') + # print(allFilePaths) + sendPtRManagerMessage(sender="cmd.electron", resetWatcher=allFilePaths) + } +}) \ No newline at end of file diff --git a/inst/App/fileIO/serverFileDescriptor.R b/inst/App/fileIO/serverFileDescriptor.R index 7c2d939f..f4199704 100644 --- a/inst/App/fileIO/serverFileDescriptor.R +++ b/inst/App/fileIO/serverFileDescriptor.R @@ -1,12 +1,6 @@ fileDescDB<-reactiveVal( - tibble( - tabId='bogus', - isSaved=FALSE, - filePath="?", - anonNo =1, - mode='ptr' - )[0,] + initialFileDescDB() ) getNextAnonymousFileName<-reactive({ @@ -20,14 +14,17 @@ getNextAnonFileNum<-reactive({ }) # to be called from serverFileTab.R::addFileTab -addFileDesc<-function( pageId, docFilePath, fileSaveStatus, fileMode){ +addFileDesc<-function( pageId, docFilePath, fileSaveStatus, fileMode, parId=NA, parMode=NA){ if(identical(docFilePath,"?")){ anonNo<-getNextAnonFileNum() } else { anonNo<-0 } + if(is.null(parId)){ + parId=NA + } tb<-tibble(tabId=pageId, isSaved=fileSaveStatus, - filePath=docFilePath, anonNo, mode=fileMode) + filePath=docFilePath, anonNo, mode=fileMode, parId=parId, parMode=parMode) fd<- fileDescDB() fd<-bind_rows(fd,tb) fileDescDB(fd) @@ -35,7 +32,6 @@ addFileDesc<-function( pageId, docFilePath, fileSaveStatus, fileMode){ getMode<-reactive({ - # cat('>---> getMode\n') tabId<-input$pages # getTibTabId() if(is.null(tabId) || identical(tabId, 'bogus')){ mode<-NULL @@ -48,6 +44,22 @@ getMode<-reactive({ mode }) +getParMode<-reactive({ + # cat('>---> getParMode\n') + tabId<-input$pages # getTibTabId() + # cat(paste('tabId=',format(tabId))) + if(is.null(tabId) || identical(tabId, 'bogus')){ + parMode<-NULL + } else { + fd<-fileDescDB() + parMode<-fd[fd$tabId==input$pages,]$parMode + if(length(parMode)>0 && is.na(parMode)){ + parMode<-NULL + } + } + parMode +}) + # in getModeX we need to insert flag to enable/disable appmode # we could use shinyjs to query a property of a (hidden) node? # or use ptR.js to do an on.change ? @@ -121,7 +133,7 @@ setFileDescSaved<-function(pageId, fileSaveStatus){ fd[fd$tabId==pageId,"isSaved"]<-fileSaveStatus fileDescDB(fd) } - cat('setFileDescSaved: pageId=',pageId,', savedStatus=',fileSaveStatus,"\n") + # cat('setFileDescSaved: pageId=',pageId,', savedStatus=',fileSaveStatus,"\n") sendFileTabsMessage(tabId=pageId, sender='savedStatus', saveStatus=fileSaveStatus) log.fout(setFileDescSaved) @@ -137,6 +149,15 @@ getAllNamedUnsavedFiles<-reactive({ fd }) +getAllNamedFiles <- function(){ + fd<-fileDescDB() + fd<-filter(fd, filePath!="?") + fd +} + + + + # get the saved status for the current page getFileSavedStatus<-reactive({ pageId<-input$pages @@ -177,3 +198,6 @@ removeFileDesc<-function(pageId, path=getWorkSpaceDir() ){ # cat('<---< removeFileDesc\n') } + + + diff --git a/inst/App/fileIO/serverGenShinyFilesSaveObservers.R b/inst/App/fileIO/serverGenShinyFilesSaveObservers.R index abc321cc..90a9220a 100644 --- a/inst/App/fileIO/serverGenShinyFilesSaveObservers.R +++ b/inst/App/fileIO/serverGenShinyFilesSaveObservers.R @@ -14,12 +14,13 @@ genShinySaveFilesObservers<-function(input, session){ if('cancel' %in% names(rtList)){ if(rtList$cancel=='close'){ tabId=popTabRequest() - if(mssg$docFilePath!="?"){ - addToRecentFiles(mssg$docFilePath) + docFilePath=getFileDescriptor(tabId)$filePath + if(!is.null(docFilePath) && docFilePath!="?"){ + addToRecentFiles(docFilePath) } closeTabNow(tabId) } else { - setTabRequest(sender=NULL, tabs=NULL) + setTabRequest(cmd=NULL, tabs=NULL) } } else { fp.dt<-parseSavePath(c(home='~'), rtList) diff --git a/inst/App/fileIO/serverLoadWorkSpace.R b/inst/App/fileIO/serverLoadWorkSpace.R index a86b5c45..2e0cd4d5 100644 --- a/inst/App/fileIO/serverLoadWorkSpace.R +++ b/inst/App/fileIO/serverLoadWorkSpace.R @@ -27,7 +27,6 @@ restoreWorkSpace<-reactive({ } wsPages<-list() - ptRproj<-pprj() selectedTab<-readCurrentTab() @@ -35,12 +34,16 @@ restoreWorkSpace<-reactive({ # 1. load all pages into a list. for(filePath in fileWSPaths){ + page<-readRDS(filePath) # A. assign tabIds to each page id=basename(filePath) if(!is.null(ptRproj$pathToProj)){ docFilePath=page$fileDescriptor.filePath page$fileDescriptor.filePath<-sub( ptRproj$pathToProj, editOption$currentProjectDirectory, docFilePath) + if(!file.exists(page$fileDescriptor.filePath)){ + next # omit this, else saving will cause an error + } saveRDS(page,filePath) } wsPages[[id]]<-page @@ -53,10 +56,14 @@ restoreWorkSpace<-reactive({ if(length(tibAs)>0){ names(tibAs)<-gsub(pattern, '', names(tibAs)) tibAs[sapply(tibAs,is.null)]<-NA + setdiff(names(initTib),names(tibAs))->tmp + if(length(tmp)>0){ + tmp<-sapply(tmp, function(x){NA}, USE.NAMES = T) + tibAs<-c(tibAs,tmp) + } } tibAs }) - rtv<-bind_rows( rtv) if(ncol(rtv)==0){ rtv<-initTib @@ -88,10 +95,12 @@ restoreWorkSpace<-reactive({ fileSaveStatus=page$fileDescriptor.isSaved txt=page$code - if(fileSaveStatus==TRUE && file.exists(docFilePath)){ + + if(identical(fileSaveStatus,TRUE) && file.exists(docFilePath)){ tryCatch( {txt<-paste(readLines(docFilePath), collapse="\n")}, error=function(e){ + e<-e$message cat("Unable to read file:", paste(e, collapse="\n")) return(NULL) #bail } diff --git a/inst/App/fileIO/serverPage2Workspace.R b/inst/App/fileIO/serverPage2Workspace.R index 9205a015..c52cc7b0 100644 --- a/inst/App/fileIO/serverPage2Workspace.R +++ b/inst/App/fileIO/serverPage2Workspace.R @@ -8,31 +8,32 @@ savePage<-function(pageId, path=getWorkSpaceDir()){ fileName=paste0(path,"/",pageId,".rda") asel<-reactiveValuesToList(selectedAsset) fileDescriptor=getFileDescriptor(pageId) - backdrop=getPageBackDrop(pageId) - grid=getPageSvgGrid(pageId) - trib<-getPageUseTribble(pageId) - dnip<-getPageDnippetsDB(pageId) - widg<-getPageWidgetDB(pageId) - preprocPage<-getPagePreprocPageDB(pageId) - # print(widg) - rtv<-c( - fileDescriptor=getFileDescriptor(pageId), - code=getCode(), - assetSelection=asel, - backdrop=backdrop, - grid=grid, - trib=trib, - dnip=dnip, - widg=widg, - preprocPage=preprocPage - ) - - # ppE<-getPreProcPtEntries(pageId) - # if(length(ppE)!=0 && nrow(ppE)>0){ - # rtv<-c(rtv, preprocScripts=ppE) - # } - if(length(preprocPage)) - saveRDS(object=rtv, file = fileName) + if(length(fileDescriptor)>0){ + backdrop=getPageBackDrop(pageId) + grid=getPageSvgGrid(pageId) + trib<-getPageUseTribble(pageId) + dnip<-getPageDnippetsDB(pageId) + widg<-getPageWidgetDB(pageId) + preprocPage<-getPagePreprocPageDB(pageId) + rtv<-c( + fileDescriptor=getFileDescriptor(pageId), + code=getCode(), + assetSelection=asel, + backdrop=backdrop, + grid=grid, + trib=trib, + dnip=dnip, + widg=widg, + preprocPage=preprocPage + ) + + # ppE<-getPreProcPtEntries(pageId) + # if(length(ppE)!=0 && nrow(ppE)>0){ + # rtv<-c(rtv, preprocScripts=ppE) + # } + # if(length(preprocPage)) + saveRDS(object=rtv, file = fileName) + } log.fout(savePage) } } diff --git a/inst/App/fileIO/serverShinyFiles.R b/inst/App/fileIO/serverShinyFiles.R index d025dc1c..c982b7ac 100644 --- a/inst/App/fileIO/serverShinyFiles.R +++ b/inst/App/fileIO/serverShinyFiles.R @@ -23,12 +23,13 @@ # } shinyFileChoose(input, "buttonFileOpen", session=session, roots=c(home="~"), - filetypes=c('R','PTR','SVGR','js','dnds')) + filetypes=c('R','PTR','SVGR','js','dnds', 'Rmd')) shinyFileChoose(input,"buttonFileOpenProject", session=session, roots=c(home="~"), filetypes=c('pprj')) shinyFileChoose(input,"buttonSnippetImport", session=session, roots=c(home="~"), filetypes=c('snip')) shinyFileChoose(input,"buttonDnippetImport", session=session, roots=c(home="~"), filetypes=c('dnds')) shinyFileChoose(input,"buttonPreProcPtImport", session=session, roots=c(home="~"), filetypes=c('R')) shinyFileChoose(input,"buttonPreProcAtImport", session=session, roots=c(home="~"), filetypes=c('R')) +shinyFileChoose(input,"buttonChoiceSetImport", session=session, roots=c(home="~"), filetypes=c('txt')) diff --git a/inst/App/global.R b/inst/App/global.R index 4e316683..4bdd5e74 100644 --- a/inst/App/global.R +++ b/inst/App/global.R @@ -47,10 +47,11 @@ notNull<-function(...) { sapply( - c('shiny','shinyjs', 'R.utils', 'svgR', 'shinyAce', 'rowPicker', 'stringr', 'jsonlite', 'fs', - 'shinyDMDMenu', 'shinyFiles', 'shinythemes', 'colourpicker', 'shinyWidgets', - 'bsplus','shinyjqui', 'knitr', 'tidyverse'), + c('shiny','shinyjs', 'shinyalert', 'R.utils', 'svgR', 'shinyAce', 'jsonlite', 'rowPicker', 'fs', + 'shinyDMDMenu', 'shinyFiles', 'shinythemes', 'colourpicker', 'shinyWidgets', 'jqScrollBar', + 'bsplus','shinyjqui', 'rmarkdown', 'knitr', 'tidyverse'), library, character.only=TRUE) +# 'stringr', , in "tidyverse" #library("RColorBrewer") # options(shiny.error = recover) @@ -61,20 +62,28 @@ sapply( # the following constants would be better if placed in a list or # alteratively use lockBinding to fix the value defTag<-"ptR" + +# appears in serverPanelDispatch transformTag<-"Transforms" +svgPanelTag<-'svgPanel' errorPanelTag<-"errorPanel" RPanelTag='RPanel' -svgPanelTag<-'svgPanel' -rmdPanelTag<-'rmdPanel' +appPanelTag<-'appPanel' +rmdPanelTag<-'rmdPanel' textPanelTag<-'textPanel' -javascriptPanelTag<-'javascriptPanel' snippetPanelTag<-'snippetPanel' -appPanelTag<-'appPanel' +javascriptPanelTag<-'javascriptPanel' + + + tibTag<-'tib' resourceDir='aux' -preprocChoices<-list(points=c("onNewPt", "onMovePt", "onMoveMat"), attrs=c('onNewRow', 'onChangeRow')) +preprocChoices<-list( + points=c("onNewPt", "onMovePt", "onMoveMat"), + attrs=c('onNewRow', 'onChangeRow') +) #----begin external resources loaded prior to server------------ # must be loaded prior to alles @@ -84,11 +93,10 @@ source("util/extNmode.R") source("util/logger.R") #---used to build the UI portion - +source('util/pointRLogoSVG.R') source("fileIO/genShinyFilesOpenButtons.R") source("fileIO/genShinyFilesSaveButtons.R") source("leftPanel/menu/UIProjectTemplateMenu.R") -source("leftPanel/menu/UIProjectSampleMenu.R") source("leftPanel/menu/UIbuildLeftMenu.R") source("leftPanel/mid/UIcontextMenu.R") diff --git a/inst/App/leftPanel/dnippets/serverDnippetCntrl.R b/inst/App/leftPanel/dnippets/serverDnippetCntrl.R index 53906866..8135b641 100644 --- a/inst/App/leftPanel/dnippets/serverDnippetCntrl.R +++ b/inst/App/leftPanel/dnippets/serverDnippetCntrl.R @@ -13,6 +13,7 @@ removeFromDnippetsSelectionAll<-function(dnName ){ observeEvent(c( getDnippetsAll(), dnippetsDB$usage, input$pages),{ + log.fout(c( getDnippetsAll(), getDnippetsSelected(), input$pages)) if(!is.null(input$pages)){ selected<-getDnippetsSelected() mode<-getMode() @@ -25,7 +26,7 @@ observeEvent(c( getDnippetsAll(), dnippetsDB$usage, input$pages),{ ) dnippets<-dnippetSelection$all[selected] - dnippets<-unlist(dnippets,recursive=F) + dnippets<-unlist(dnippets,recursive=FALSE) names(dnippets)<-NULL if(length(dnippets)==0){ sendPtRManagerMessage(sender='cmd.dnippet.file.load', removeDrippets=runif(1)); @@ -34,7 +35,7 @@ observeEvent(c( getDnippetsAll(), dnippetsDB$usage, input$pages),{ } } - if(length(input$pages) && length(getDnippetsAll())>0 && + if(length(input$pages)>0 && length(getDnippetsAll())>0 && any(sapply(c('ptr','javascript'), function(x)identical( getModeX(),x ))) ){ showElement('selectedDnippetButtonBoxContainer') @@ -42,7 +43,7 @@ observeEvent(c( getDnippetsAll(), dnippetsDB$usage, input$pages),{ hideElement('selectedDnippetButtonBoxContainer') } log.fout(c( getDnippetsAll(), getDnippetsSelected(), input$pages)) -}, label='getDnippetsAll+usage+pages') +}, label='getDnippetsAll+usage+pages', ignoreNULL = FALSE,) observeEvent(input$selectedDDDnippets,{ if(!is.null(input$pages)){ @@ -50,6 +51,6 @@ observeEvent(input$selectedDDDnippets,{ setDnippetsSelected(input$pages , selected) } -}, ignoreInit = TRUE, ignoreNULL = TRUE, label='selectedDDDnippets') +}, ignoreInit = TRUE, ignoreNULL = FALSE, label='selectedDDDnippets') diff --git a/inst/App/leftPanel/footer/processCommit.R b/inst/App/leftPanel/footer/processCommit.R index 86c80d5e..3b74b787 100644 --- a/inst/App/leftPanel/footer/processCommit.R +++ b/inst/App/leftPanel/footer/processCommit.R @@ -1,12 +1,20 @@ src2sourceType<-function(src){ #not used !! lines<-strsplit(src,"\n") lines<-lines[[1]] - svgRPos<-grep("^\\s*svgR\\(",lines) - if(length(svgRPos)==0){ # just R code I guess - # browser() - setSourceType(sourceType=RPanelTag) # + if(length(lines)==0){ + setSourceType(sourceType=textPanelTag) } else { - setSourceType(sourceType=svgPanelTag) #SVG code + if(grepl("^---",lines[1])){ + setSourceType(sourceType=rmdPanelTag) + } else{ + svgRPos<-grep("^\\s*svgR\\(",lines) + if(length(svgRPos)==0){ # just R code I guess + # browser() + setSourceType(sourceType=RPanelTag) # + } else { + setSourceType(sourceType=svgPanelTag) #SVG code + } + } } } @@ -18,6 +26,7 @@ processCommit<-reactive({ clearErrorMssg() mode<-getModeX() + log.val(mode) if(length(mode)!=1){ cat('missing mode\n'); browser() return(NULL) @@ -53,31 +62,22 @@ processCommit<-reactive({ } if(!hasError()){ tabId<-input$pages - # cat("tabId=",tabId,"\n") - #cat_list<<-c( cat_list,'>---> processCommit::savePage\n') savePage(tabId) - #cat_list<<-c( cat_list,'<---< processCommit::savePage\n') } - # log.fout( processCommit) + # log.fout(processCommit) }) - processSvgR<-reactive({ - #src<-request$code +# log.fin(processSvgR) src<-getCode() - # cat('>----> processSvgR::\n') if(length(src)==1){ - ptRList<-getPtDefs()$tib tryCatch({ - lines<-strsplit(src,"\n") + initialEnv<-getEnvList() + lines<-strsplit(src,"\n") lines<-lines[[1]] - # cat('ptRPos\n') ptRPos<-grep("^\\s*ptR<-",lines) - # cat('svgRPos\n') svgRPos<-grep("^\\s*svgR\\(",lines) - # cat('done\n') if(length(svgRPos)==0){ # just R code I guess - # browser() setSourceType(sourceType=RPanelTag) # } else { setSourceType(sourceType=svgPanelTag) #SVG code @@ -92,32 +92,25 @@ processSvgR<-reactive({ if(length(svgRPos)==0){ # just R code I guess #test for error and capture output # capture capture output as mssg - env<-new.env() + env1<-getEnvList() parsedCode<-parse(text=src) output<-lapply(parsedCode, function(x){ - captureOutput(eval(x, envir=env)) + captureOutput(eval(x, envir= env1 )) }) output<-paste( unlist(output), collapse="\n" ) output<-paste("Output:",output,sep="\n") setCapturedMssg(output) setSourceType(sourceType=RPanelTag) #no error, just R code } else { # presume to be svgR code - # next check if it can be run - # Set wd to the current project or if no project, then to home - dpath<-getDirPath() - if(identical(dpath, '~/.ptR')){ - dpath<-'~' + env2<-getEnvList() + #if parMode is dndsnippet, need to add to env2, WH=c(48,32) + if(identical(getParMode(), 'dnippets')){ + env2<-c(env2, list(WH=c(48,32))) } - wd<-paste0('\nsetwd("',dpath,'")\n\n') - parsedCode<-parse(text=paste0(wd,src) ) - #parsedCode<-parse(text=src) - # svg<-eval(parsedCode) - # if(identical(class(svg),'svgDoc')){ - # w<-svg$root$getAttr('width') - # h<-svg$root$getAttr('height') - # #set WH in selected... - # } - output<-captureOutput(eval(parsedCode, new.env())) + + parsedCode<-parse(text=paste0(src) ) + + output<-captureOutput(eval(parsedCode, envir=env2 )) output<-paste( output, collapse="\n" ) output<-paste("Output:",output,sep="\n") setCapturedMssg(output) @@ -130,10 +123,13 @@ processSvgR<-reactive({ }, #end of try error=function(e){ #Error handler for commit + e<-e$message if(all(!str_detect(e,'Output:'))){ e<-c(e,traceback()) } - err<-paste(unlist(e), collapse="\n", sep="\n") + err<-unlist(e) + err<-paste(err, collapse="\n", sep="\n") + # log.val(err) #try to locate where the error occured if(str_detect(err, 'parse')){ m<-str_match(err, ":([0-9]+):([0-9]+):") @@ -157,7 +153,8 @@ processSvgR<-reactive({ } #end of error handler ) #end of tryCatch } #end of if(length==1) - # cat('<----< processSvgR::\n') + + # log.fout(processSvgR) }) diff --git a/inst/App/leftPanel/footer/processDnip.R b/inst/App/leftPanel/footer/processDnip.R index f5f2b030..0dee0b2d 100644 --- a/inst/App/leftPanel/footer/processDnip.R +++ b/inst/App/leftPanel/footer/processDnip.R @@ -4,6 +4,8 @@ processDnip<-reactive({ clearErrorMssg() # src<-request$code src<-getCode() + updateAceExt( id= getAceEditorId(), sender='commit.removeMarkers', removeAllMarkers='removeAllMarkers', updateRmdDependents=getAceEditorId() ) + setSourceType(rmdPanelTag) if(length(src)==1 && nchar(src)>0){ @@ -12,12 +14,13 @@ processDnip<-reactive({ src<-dripplets2Rmd(src) # cat_list<<-c( cat_list,'<--< dripplets2Rmd\n') # cat_list<<-c( cat_list,'>-->> knit2html\n') - knit2html(text = src, fragment.only = FALSE, quiet = TRUE) + knit2html(text = src, fragment.only = FALSE, quiet = TRUE, envir=getEnvList() ) # cat_list<<-c( cat_list,'<--<< knit2html\n') setSourceType(sourceType=rmdPanelTag) } , #end of try error=function(e){ + e<-e$message if(all(!str_detect(e,'Output:'))){ e<-c(e,traceback()) } diff --git a/inst/App/leftPanel/footer/processKnit.R b/inst/App/leftPanel/footer/processKnit.R index cf1cc967..53095295 100644 --- a/inst/App/leftPanel/footer/processKnit.R +++ b/inst/App/leftPanel/footer/processKnit.R @@ -3,6 +3,8 @@ processKnit<-reactive({ # cat_list<<-c( cat_list,">---> processKnit\n") clearErrorMssg() #src<-request$code + updateAceExt( id= getAceEditorId(), sender='commit.removeMarkers', removeAllMarkers='removeAllMarkers', updateRmdDependents=getAceEditorId() ) + src<-getCode() setSourceType(rmdPanelTag) @@ -15,12 +17,14 @@ processKnit<-reactive({ } tryCatch({ # cat_list<<-c( cat_list,'>--> knit2html\n') - knit2html(text = src, fragment.only = FALSE, quiet = TRUE, envir=new.env()) + # knit2html(text = src, fragment.only = FALSE, quiet = TRUE, envir=new.env()) + knit2html(text = src, fragment.only = FALSE, quiet = TRUE, envir=getEnvList() ) # cat_list<<-c( cat_list,'<--< knit2html\n') setSourceType(sourceType=rmdPanelTag) } , #end of try error=function(e){ + e<-e$message if(all(!str_detect(e,'Output:'))){ e<-c(e,traceback()) } diff --git a/inst/App/leftPanel/footer/serverButtons.R b/inst/App/leftPanel/footer/serverButtons.R index 51879193..022283db 100755 --- a/inst/App/leftPanel/footer/serverButtons.R +++ b/inst/App/leftPanel/footer/serverButtons.R @@ -12,7 +12,7 @@ observeEvent(input$commitMssg, { #---commit rmdView button----- observeEvent(input$writeNOpen ,{ - setTabRequest(sender='buttonCmd.rmdViewer', tabs=input$pages) + setTabRequest(cmd='buttonCmd.rmdViewer', tabs=input$pages) }, label= "writeNOpen") appRunner<-reactiveValues( @@ -28,7 +28,7 @@ if(usingElectron){ appRunner$log<-"" selection<-getAllNamedUnsavedFiles()$tabId if(length(selection)>0){ - setTabRequest(sender='fileCmd.runApp', tabs=selection) + setTabRequest(cmd='fileCmd.runApp', tabs=selection) } else { app2RunPath<-getFileDescriptor(appRunner$tabId)$filePath sendPtRManagerMessage(sender='cmd.electron', app2RunPath=app2RunPath, tabId= appRunner$tabId) @@ -57,6 +57,83 @@ if(usingElectron){ appRunner$log<-c(appRunner$log, input$appLog$mssg) }, label="appLog") + + replaceContents<-function(aceId, contents){ + updateAceExt(id=aceId, sender='mause.add', setValue=contents, setDocFileSaved=TRUE) + } + externalReplacement<-reactiveValues( + aceId='', + newContents='' + ) + + #!!! move this elsewhere + observeEvent(input$fileChanged,{ + changedFile<-input$fileChanged$mssg + + + fd<-fileDescDB() + if(!(identical(fd$filePath,"?"))){ + fd$filePath<-normalizePath(fd$filePath) + } + + tb<-filter(fd, filePath==changedFile) + # cat("fileChanged 2\n") + if(nrow(tb)>0){ + # cat("fileChanged 2\n") + pid<-tb$tabId + aceId<-tabID2aceID(pid) + # cat("aceId=",aceId) + oldeContents<-input[[aceId]] + # print(oldeContents) + newContents<-paste(readLines(changedFile), collapse = "\n") + if(newContents==oldeContents){ + # print("no update") + } else { + # print("update") + if(tb$isSaved){ + # print("auto-update") + replaceContents(aceId, newContents) + } else { + # ask + externalReplacement$newContents=newContents + externalReplacement$aceId=aceId + # print("ask to update") + fileName<-basename(changedFile) + showModal(updateChangedFileModal(fileName)) + } + } + } + + + + + + + + }) + #--------change modal------------------------------ + + updateChangedFileModal <- function(fileName='File') { + txt1<-paste(fileName,'has been modified on disk.' ) + txt2<-paste('Reload from disk?') + modalDialog( + span(txt1), + br(), + span(txt2), + footer = tagList( + modalButton("Keep as is"), + actionButton("updateChangedFileButton", "Reload") + ) + ) + } + + + + observeEvent(input$updateChangedFileButton, { + replaceContents(externalReplacement$aceId, externalReplacement$newContents) + removeModal() + }) + } diff --git a/inst/App/leftPanel/helpSVG.R b/inst/App/leftPanel/helpSVG.R index f8a9b13b..e4fbbbaf 100644 --- a/inst/App/leftPanel/helpSVG.R +++ b/inst/App/leftPanel/helpSVG.R @@ -16,12 +16,13 @@ observeEvent(input$helpMssg, { #---------------------- -output$htmlHelpSvg_Out<-renderText( +output$htmlHelpSvg_Out<-renderText({ htmlHelpSvgOut() -) +}) htmlHelpSvgOut<-reactive({ - HTML(helpsvgR$html) + h<-helpsvgR + HTML(h$html) }) helpsvgR<-reactiveValues( @@ -74,7 +75,6 @@ observeEvent(input$dismiss,{ svgQueryAddr2Help<-function(queryAddr){ # 1. trim off the front addr<-basename(queryAddr) - if(addr=="00Index.html"){ queryTopic<-"00Index.html" } else { @@ -113,7 +113,9 @@ svgQueryTopic2Help<-function(query){ pkgRdDB = tools:::fetchRdDB(file.path(find.package(pkg), 'help', pkg)) tools::findHTMLlinks(pkgDir=path,level=0)->links topics<-names(pkgRdDB) + if(length(query)!=1){ browser() } # debug code!!! + if(!(query %in% topics)){ # we default to the index # we generate the index page by cropping the original help page tmp<-readLines(file.path(path.package("svgR"), "html", "00Index.html") ) @@ -128,21 +130,30 @@ svgQueryTopic2Help<-function(query){ pos<-which(str_detect(html,"

")) html<-html[-(1:(pos-1))] html[1]<-sub( pattern = "^", "", html[1] ) + html[1]<-sub("R: Element Generators Indexed by Category", "", html[1]) + html<-paste(html,collapse="\n") } else { #query was found, now lets grab the page + + txtConnection<-textConnection("html","w") tools::Rd2HTML( pkgRdDB[[query]], package=pkg, - Links=links, + Links=links, + fragment=TRUE, out=txtConnection ) + + textConnectionValue(txtConnection)->tmp + tmp[3]=paste("

",tmp[10]," {svgR}

") + tmp[5]=paste("

",tmp[5],"

") + tmp[10]="" + tmp[8]="" + html<-paste(tmp,collapse="\n") close(txtConnection) } - html[1]<-sub("R: Element Generators Indexed by Category", "", html[1]) - html<-paste(html,collapse="\n") - html # Now we want to send a request back to the # server in the user clicks a hyperlink to another page @@ -160,7 +171,9 @@ svgQueryTopic2Help<-function(query){ # trigger help for short cut keys observeEvent( input$keyBoardHelp,{ + kb<-input$keyBoardHelp + }) #handle back button for help diff --git a/inst/App/leftPanel/menu/UIProjectSampleMenu.R b/inst/App/leftPanel/menu/UIProjectSampleMenu.R deleted file mode 100644 index 66cbc861..00000000 --- a/inst/App/leftPanel/menu/UIProjectSampleMenu.R +++ /dev/null @@ -1,9 +0,0 @@ - -UIProjectSampleMenu<-function(){ - projTemplateNames<-dir(filePath(ptRPath, "App","sampleProjects")) - - tmp<-lapply(projTemplateNames, function(prjname){ - shinyDMDMenu::menuItem(prjname, value=paste0('projectSample-',prjname)) - }) - do.call(tagList, tmp) -} \ No newline at end of file diff --git a/inst/App/leftPanel/menu/UIProjectTemplateMenu.R b/inst/App/leftPanel/menu/UIProjectTemplateMenu.R index ff98476b..eb4133de 100644 --- a/inst/App/leftPanel/menu/UIProjectTemplateMenu.R +++ b/inst/App/leftPanel/menu/UIProjectTemplateMenu.R @@ -1,9 +1,71 @@ UIProjectTemplateMenu<-function(){ - projTemplateNames<-dir(filePath(ptRPath, "App","projectTemplates")) - - tmp<-lapply(projTemplateNames, function(prjname){ - shinyDMDMenu::menuItem(prjname, value=paste0('projectTemplate-',prjname)) - }) + projTemplatePaths<-list.dirs( + file.path(ptRPath, "App","projectTemplates"), full.names = TRUE, recursive = FALSE + ) + userTemplatePaths<-list.dirs( + file.path(homeDir, '.ptR','.templates'), full.names = TRUE, recursive = FALSE + ) + templatePaths<-c(projTemplatePaths,userTemplatePaths) +# templateNames<-basename(templatePaths) #gsub('-',' ',basename(templatePaths)) + templateNames<-gsub('-',' ',basename(templatePaths)) + templatePaths<-paste0('projectTemplate-',templatePaths) + tmp<-mapply(shinyDMDMenu::menuItem, templateNames, value=templatePaths,SIMPLIFY=FALSE) do.call(tagList, tmp) -} \ No newline at end of file + +} + + + +UIRemoveUserTemplate<-function(){ + userTemplatePaths<-list.dirs( + file.path(homeDir, '.ptR','.templates'), full.names = TRUE, recursive = FALSE + ) + if(length(userTemplatePaths)==0){ + NULL + } else { + userTemplateNames<-basename(userTemplatePaths) + userTemplatePaths<-paste0('removeTemplate-',userTemplatePaths) + tmp<-mapply(shinyDMDMenu::menuItem, userTemplateNames, value=userTemplatePaths, SIMPLIFY=FALSE) + do.call(tagList, tmp) + } +} + + +updateNewProjectMenu<-function(session){ + # 1 remove subMenuDropdown + removeDMDM(session=session, menuBarId="editNavBar", entry='New Project') + #recreate dropdow + submenu<-subMenuDropdown('New Project', + # shinyDMDMenu::menuItem('New Basic Project', value='newBasicProject'), + shinyDMDMenu::menuItem('Clone of Existing Project', value='newCloneProject'), + # shinyDMDMenu::menuItem('svgR-based ShinyInput Control', value='newSimpleInputWidget'), + UIProjectTemplateMenu() + ) + # 4 insertsubmenu + if(!is.null(submenu)){ + insertAfterDMDM( + session, menuBarId = "editNavBar", + entry="New File", submenu= submenu + ) + } +} +updateRemoveTemplateMenu<-function(session){ + # 1 remove subMenuDropdown + removeDMDM(session=session, menuBarId="editNavBar", entry="Remove from Menu") + #recreate dropdown + templateMenuList<-UIRemoveUserTemplate() + submenu<-subMenuDropdown("Remove from Menu", + templateMenuList + ) + # 4 insertsubmenu + #if(!is.null(UIRemoveUserTemplate())){ + insertAfterDMDM( + session, menuBarId = "editNavBar", + entry="addTemplate", submenu= submenu + ) + #} + if(is.null(templateMenuList)){ + disableDMDM(session, menuBarId="editNavBar", entry="Remove from Menu") + } +} diff --git a/inst/App/leftPanel/menu/UIbuildLeftMenu.R b/inst/App/leftPanel/menu/UIbuildLeftMenu.R index b4bf33f6..1c123667 100644 --- a/inst/App/leftPanel/menu/UIbuildLeftMenu.R +++ b/inst/App/leftPanel/menu/UIbuildLeftMenu.R @@ -6,9 +6,9 @@ buildLeftMenu<-function(version){ menuBarId="editNavBar", menuDropdown( "File", - shinyDMDMenu::menuDropdown( + shinyDMDMenu::subMenuDropdown( "New File", - shinyDMDMenu::menuDropdown('ptR script', + shinyDMDMenu::subMenuDropdown('ptR script', shinyDMDMenu::menuItem("ptR list containing a tibble", value="newPtrTibScript"), shinyDMDMenu::menuItem("ptR list containing a matrix", value="newPtRMatScript"), shinyDMDMenu::menuItem("svgR without a ptR list", value="newPtRSVGScript") @@ -24,21 +24,16 @@ buildLeftMenu<-function(version){ # menuDivider(), # shinyDMDMenu::menuItem('Plain Text Doc', value='newText') ), - menuDropdown('New Project', - shinyDMDMenu::menuItem('New Basic Project', value='newBasicProject'), + subMenuDropdown('New Project', + # shinyDMDMenu::menuItem('New Basic Project', value='newBasicProject'), shinyDMDMenu::menuItem('Clone of Existing Project', value='newCloneProject'), - #shinyDMDMenu::menuItem('svgR-based ShinyInput Control', value='newSimpleInputWidget'), + # shinyDMDMenu::menuItem('svgR-based ShinyInput Control', value='newSimpleInputWidget'), UIProjectTemplateMenu() - - ), - menuDropdown('Sample Project', - UIProjectSampleMenu() - ), - menuDropdown("Recent Projects"), + subMenuDropdown("Recent Projects"), menuDivider(), shinyDMDMenu::menuItem("Open File", value='openFile'), - menuDropdown("Recent Files"), + subMenuDropdown("Recent Files"), menuDivider( id='recentProjDivider'), shinyDMDMenu::menuItem("Open Project...", value='openProject'), @@ -64,41 +59,57 @@ buildLeftMenu<-function(version){ # shinyDMDMenu::menuItem('Delete Tibble', value='cmdDeleteTibble') # ), menuDropdown( - 'Edit', - menuDropdown( - "Options", + 'Options', + subMenuDropdown( + "Editor", shinyDMDMenu::menuItem("Theme" ), shinyDMDMenu::menuItem("Font Size"), shinyDMDMenu::menuItem("Adjust Tabs", value="adjustTabs"), shinyDMDMenu::menuItem("Toggle White Space", value="toggleWhiteSpace"), shinyDMDMenu::menuItem(defaultOpts$tabType) ), - menuDivider(), - menuDropdown( + #menuDivider(), + subMenuDropdown( "Import Addin", shinyDMDMenu::menuItem("Snippets", value="importSnippetFile"), shinyDMDMenu::menuItem("Drag&Drops", value='importDndSnippetsFile') + ), + subMenuDropdown( + "Manage Template Menu", + shinyDMDMenu::menuItem("Add Current Project", value="addTemplate"), + shinyDMDMenu::subMenuDropdown("Remove from Menu", UIRemoveUserTemplate()) ) ), menuDropdown( "Help", shinyDMDMenu::menuItem("Editor ShortCuts"), shinyDMDMenu::menuItem("Element Reference"), + if(usingElectron){ shinyDMDMenu::menuItem("svgR User Guide", value="svgRUserGuide") } else { shinyDMDMenu::menuItem(HTML("
  • svgR User Guide
    • ")) }, if(usingElectron){ - menuDropdown( + subMenuDropdown( + "Preprocessing", + shinyDMDMenu::menuItem(HTML("attribute"), value="preprocAttrHelp"), + shinyDMDMenu::menuItem(HTML("point"), value="preprocPtHelp") + ) + } else { + NULL + }, + if(usingElectron){ + subMenuDropdown( "Useful Links", + shinyDMDMenu::menuItem(HTML("youtube playlist")), shinyDMDMenu::menuItem(HTML("io.svgR")), shinyDMDMenu::menuItem(HTML("W3C SVG reference")) ) } else{ - menuDropdown( + subMenuDropdown( "Useful Links", - + shinyDMDMenu::menuItem(HTML("
  • youtube playlist
    • ")), shinyDMDMenu::menuItem(HTML("
  • io.svgR
    • ")), shinyDMDMenu::menuItem(HTML("
  • W3C SVG reference
    • ")) ) diff --git a/inst/App/leftPanel/menu/cmdAbout.R b/inst/App/leftPanel/menu/cmdAbout.R index baf0a72a..dc8c091f 100644 --- a/inst/App/leftPanel/menu/cmdAbout.R +++ b/inst/App/leftPanel/menu/cmdAbout.R @@ -6,11 +6,13 @@ cmdAbout<-function(){ modalAbout <- function(..., size = "m" ) { modalDialog( - div( img(src="ptR/pointRLogo.SVG")), + # div( pointRLogoSVG()), + div(img(src="ptR/pointRlogo.svg")), div( p(version, align="right")), div( width="100%", p(paste( "The purpose of this application is to provide an open-flexible tool for creating SVG using the svgR package.", + "This tool is built using the RStudio Shiny server and Electron as a wrapper", "The svgR package is an R package to for creating SVG graphics.", "SVG is short for scalar vector graphics.", "Applications include Shiny apps, Rdocs, or even generating a plain SVG file.")), diff --git a/inst/App/leftPanel/menu/cmdFileClose.R b/inst/App/leftPanel/menu/cmdFileClose.R index 864a2f6a..e38f393b 100644 --- a/inst/App/leftPanel/menu/cmdFileClose.R +++ b/inst/App/leftPanel/menu/cmdFileClose.R @@ -1,9 +1,26 @@ cmdFileClose<-function(){ - setTabRequest(sender="fileCmd.close", tabs=input$pages) + # if current tab has children + # first add children, then current tab + + fd<-fileDescDB() + aid<-getAceEditorId() + aids<-filter(fileDescDB(), parId==aid)$tabId + if(length(aids)>0){ + tabs<-aceID2TabID(aids) + closeTabsNow(tabs) + } + setTabRequest(cmd="fileCmd.close", tabs=input$pages) } cmdFileCloseAll<-function(){ - sendFileTabsMessage(sender= 'fileCmd.close', getAllTabIds=runif(1)) + # 1. get all tab Ids + tabIds<-fileDescDB()$tabId + # 2. sender= 'fileCmd.close' + cmd= 'fileCmd.close' + # 3. push onto request + setTabRequest(cmd=cmd, tabs=tabIds) + + #sendFileTabsMessage(sender= 'fileCmd.close', getAllTabIds=runif(1)) } observeEvent( input$closeTab, { @@ -12,11 +29,18 @@ observeEvent( input$closeTab, { id<-input$closeTab$id if(input$closeTab$type=='tabId'){ tabId<-id + aceId<-tabID2aceID(tabId) } else { - tabId<-aceID2TabID(id) + aceId<-id + tabId<-aceID2TabID(aceId) + } + aids<-filter(fileDescDB(), parId==aceId & filePath=="?")$tabId # exclude from deletion any tabs with paths assigned + if(length(aids)>0){ + tabs<-aceID2TabID(aids) + closeTabsNow(tabs) } #removeFileDesc(tabId) - setTabRequest(sender="fileCmd.close", tabs=tabId) + setTabRequest(cmd="fileCmd.close", tabs=tabId) log.fin(input$closeTab) } } , label= "input$closeTab") diff --git a/inst/App/leftPanel/menu/cmdFileQuit.R b/inst/App/leftPanel/menu/cmdFileQuit.R index 6b361145..85181a89 100644 --- a/inst/App/leftPanel/menu/cmdFileQuit.R +++ b/inst/App/leftPanel/menu/cmdFileQuit.R @@ -1,7 +1,15 @@ cmdFileQuit<-reactive({ - storeAssetState() + log.fin(cmdFileQuit) + storeAssetState() # should check if + if("parId" %in% names( fileDescDB())){ #should remove all child tabs + aids<-filter(fileDescDB(), !is.na(parId) & filePath=="?")$tabId + if(length(aids)>0){ + tabs<-aceID2TabID(aids) + closeTabsNow(tabs) + } + } fd<-getAllNamedUnsavedFiles() choices<-fd$filePath if(length(choices)>0){ @@ -10,6 +18,7 @@ cmdFileQuit<-reactive({ } else { cmdQuitNow() } + log.fout(cmdFileQuit) }) cmdQuitNow<-reactive({ @@ -55,7 +64,7 @@ observeEvent(input$checkAll,{ cmdQuitNow() } else { #iterate over each tab id selection and save each, then quit - setTabRequest(sender='fileCmd.quit', tabs=selection) + setTabRequest(cmd='fileCmd.quit', tabs=selection) } }) @@ -68,7 +77,7 @@ observeEvent(input$quitNow,{ cmdQuitNow() } else { #iterate over each tab id selection and save each, then quit - setTabRequest(sender='fileCmd.quit', tabs=selection) + setTabRequest(cmd='fileCmd.quit', tabs=selection) } }) diff --git a/inst/App/leftPanel/menu/cmdFileSave.R b/inst/App/leftPanel/menu/cmdFileSave.R index 36e87a31..7ab3c50a 100644 --- a/inst/App/leftPanel/menu/cmdFileSave.R +++ b/inst/App/leftPanel/menu/cmdFileSave.R @@ -1,11 +1,11 @@ cmdFileSave<-function(){ - setTabRequest(sender="fileCmd.save", tabs=input$pages) + setTabRequest(cmd="fileCmd.save", tabs=input$pages) } cmdFileSaveAll<-function(){ tabIds<-getAllNamedUnsavedFiles()$tabId if(length(tabIds)>0){ - setTabRequest(sender= 'fileCmd.save', tabs=tabIds) + setTabRequest(cmd= 'fileCmd.save', tabs=tabIds) } } diff --git a/inst/App/leftPanel/menu/cmdFileSaveAs.R b/inst/App/leftPanel/menu/cmdFileSaveAs.R index 6d12b36c..be56383e 100644 --- a/inst/App/leftPanel/menu/cmdFileSaveAs.R +++ b/inst/App/leftPanel/menu/cmdFileSaveAs.R @@ -8,5 +8,5 @@ cmdFileSaveAs<-function(){ #tabId<-input$pages #sendPtRManagerMessage( id=tabId, sender='cmd.saveFileAs', saveFile=TRUE, closing=!is.null(request$closeTab), type='R') - setTabRequest(sender="fileCmd.saveAs", tabs=input$pages) + setTabRequest(cmd="fileCmd.saveAs", tabs=input$pages) } diff --git a/inst/App/leftPanel/menu/serverEditBar.R b/inst/App/leftPanel/menu/serverEditBar.R index 9dbf6755..54bd4209 100755 --- a/inst/App/leftPanel/menu/serverEditBar.R +++ b/inst/App/leftPanel/menu/serverEditBar.R @@ -5,7 +5,32 @@ observeEvent( input$editNavBar, { fileCmd<-getLeftMenuCmd() if(length(fileCmd)>0){ - + if( fileCmd =="addTemplate"){ + # cat('******* addTemplate\n') + # get projectPath + source<-getProjectFullPath() + source=dirname(source) + # getProject Name + name<-basename(source) # should be same as editOption$currentProjectName) + name<-sub("\\.pprj$",'',name) + target<-file.path(homeDir, '.ptR','.templates',name) + # cat('source=',source,"\n") + # cat('target=',target,"\n") + copyDirectory(from=source, to=target, private=TRUE, recursive=TRUE) + # copy to .ptR + # update menus + updateNewProjectMenu(session) + updateRemoveTemplateMenu(session) + } + if(grepl("removeTemplate-",fileCmd)){ + target<- str_split(fileCmd,'-')[[1]][2] + # delete templatePath + # file.remove(target,recursive=TRUE) + dir_delete(target) + # update menus + updateNewProjectMenu(session) + updateRemoveTemplateMenu(session) + } if( fileCmd %in% c("newPtrTibScript", "newPtRMatScript", "newPtRSVGScript", "newRScript" )){ #-----new cmdFileNewPtR(fileCmd) dirtyDMDM(session, "editNavBar") @@ -43,13 +68,11 @@ observeEvent( input$editNavBar, { dirtyDMDM(session, "editNavBar") } if(grepl("projectTemplate-",fileCmd)){ - templateName<- str_split(fileCmd,'-')[[1]][2] - showModal(newProjShinyCntrlModal(projTemplateName=templateName)) - dirtyDMDM(session, "editNavBar") - } - if(grepl("projectSample-",fileCmd)){ - projectName<- str_split(fileCmd,'-')[[1]][2] - showModal(sampleProjModal(projectName=projectName)) + # cat('fileCmd=',fileCmd,'\n') + #templatePath<- str_split(fileCmd,'-')[[1]][2] + templatePath<-sub('^projectTemplate-','',fileCmd) + # cat('templatePath=',templatePath,'\n' ) + showModal(newProjShinyCntrlModal(projTemplatePath=templatePath)) dirtyDMDM(session, "editNavBar") } if(fileCmd=="openProject"){ #-----open @@ -84,7 +107,7 @@ observeEvent( input$editNavBar, { editOption$currentProjectDirectory<-NULL editOption$currentProjectName<-NULL dirtyDMDM(session, "editNavBar") - #delay(500, {request$sender='startup'}) + #delay(500, {request$cmd='startup'}) #delay(500, {setRequestSender('startup')}) delay(500, {requestStartUp()}) } @@ -188,12 +211,30 @@ observeEvent( input$editNavBar, { } if(usingElectron){ + if(identical(fileCmd,"youtube playlist")){ + href='https://www.youtube.com/playlist?list=PLpvG89XJyQhlucHJxb9pr708NY1hTqSun' + sendPtRManagerMessage(sender='cmd.electron', openLink= href) + # sendPtRManagerMessage(sender='cmd.electron', openWindow= "svgRUserGuide") + dirtyDMDM(session, "editNavBar") + } if(identical(fileCmd,"svgRUserGuide")){ #href='http://mslegrand.github.io/svgR/User_Guide.html' #sendPtRManagerMessage(sender='cmd.electron', openLink= href) sendPtRManagerMessage(sender='cmd.electron', openWindow= "svgRUserGuide") dirtyDMDM(session, "editNavBar") } + if(identical(fileCmd,"preprocPtHelp")){ + #href='http://mslegrand.github.io/svgR/User_Guide.html' + #sendPtRManagerMessage(sender='cmd.electron', openLink= href) + sendPtRManagerMessage(sender='cmd.electron', openWindow= "preprocPtHelp") + dirtyDMDM(session, "editNavBar") + } + if(identical(fileCmd,"preprocAttrHelp")){ + #href='http://mslegrand.github.io/svgR/User_Guide.html' + #sendPtRManagerMessage(sender='cmd.electron', openLink= href) + sendPtRManagerMessage(sender='cmd.electron', openWindow= "preprocAttrHelp") + dirtyDMDM(session, "editNavBar") + } if(identical(fileCmd,"io.svgR")){ href='http://mslegrand.github.io/svgR' sendPtRManagerMessage(sender='cmd.electron', openLink= href) @@ -225,10 +266,8 @@ observeEvent( input$editNavBar, { } if(grepl("recentProj-",fileCmd)){ - # cat('>---> recentProjects\n') #get the name name<-sub("recentProj-","",fileCmd) - #cat('>---> recentProjects: name=', format(name),"\n") #if file fails to exist remove dirtyDMDM(session, "editNavBar") if(!file.exists(name)){ @@ -241,8 +280,6 @@ observeEvent( input$editNavBar, { } else { projName<-basename(name) pathToProj<-dirname(name) - # cat('recentFiles:: pathToProj', format(pathToProj),"\n") - # pathToProj<-path_rel(pathToProj, path_home() ) openProj(projName, pathToProj ) } dirtyDMDM(session, "editNavBar") @@ -307,13 +344,14 @@ observeEvent( editOption$currentProjectName, { if(length(editOption$currentProjectName)==0){ title='project: ' disableDMDM(session, "editNavBar", 'closeProject') + disableDMDM(session, "editNavBar", 'addTemplate') } else { title=paste0('project: ', editOption$currentProjectName) enableDMDM(session, "editNavBar", 'closeProject') + enableDMDM(session, "editNavBar", 'addTemplate') } renameDMDM(session, menuBarId="editNavBar", entry='project', newLabel=title, newValue='project') - }, ignoreNULL = FALSE) # -----------ACE EDITOR------------------------ diff --git a/inst/App/leftPanel/mid/UIcontextMenu.R b/inst/App/leftPanel/mid/UIcontextMenu.R index 3623034e..f7b35da5 100644 --- a/inst/App/leftPanel/mid/UIcontextMenu.R +++ b/inst/App/leftPanel/mid/UIcontextMenu.R @@ -9,7 +9,7 @@ UIcontextMenu<-function(){ tag('li',list(class='clickMe', span(class='icon-clone'),span('Copy') )), tag('li',list(class='clickMe', span(class='icon-scissors'),span('Cut') )), tag('li',list(class='clickMe', span(class='icon-paste'),span('Paste') )), - tag('li',list(class='clickMe', span(class='icon-cancel'),span('Delete') )) + tag('li',list(class='clickMe', span(class='icon-cancel'),span('Delete') ))#, )), hr(class='contexthr') ) @@ -18,7 +18,12 @@ UIcontextMenu<-function(){ }, tag('ul', list( id='items', - tag('li',list(class='clickMe', span(class="icon-help"), span( 'Lookup element'))) + tag('li',list(class='clickMe', span(class="icon-help"), span( 'Lookup element'))), + tag('li',list(id='rmd-insert-svgR', class='clickMe', span(class=" icon-circle-empty"), span( 'Insert svgR Block'))), + tag('li',list(id='rmd-insert-ptR', class='clickMe', span(class="icon-circle"), span( 'Insert ptR Block'))), + tag('li',list(id='rmd-edit-code', class='clickMe', span(class='icon-edit'),span('Edit Code Block') )), + tag('li',list(id='dnd-insert-block', class='clickMe', span(class=" icon-plus-squared-alt"), span( 'Insert DNDS Block'))), + tag('li',list(id='dnd-edit-svgR', class='clickMe', span(class="icon-edit"), span( 'Edit DNDS Icon'))) )) ) } \ No newline at end of file diff --git a/inst/App/leftPanel/mid/serverAce.R b/inst/App/leftPanel/mid/serverAce.R index bfc104eb..16fce540 100644 --- a/inst/App/leftPanel/mid/serverAce.R +++ b/inst/App/leftPanel/mid/serverAce.R @@ -1,10 +1,25 @@ observeEvent(input$messageFromAce, { - cat("\n>----> messageFromAce", '***** sender=',format(input$messageFromAce$sender),"\n") + # cat("\n>----> messageFromAce", '***** sender=',format(input$messageFromAce$sender),"\n") + if(length(input$messageFromAce$sender)>0){ + if(length(input$messageFromAce$preDoc)>0){ + # cat('has preDoc\n') + pDoc<-input$messageFromAce$preDoc + if(!identical(pDoc, request$pDoc)){ + pBlocks<-NULL + if(!identical(pDoc, "")){ + pBlocks<-extractCodeBlocksFromRmd(pDoc) + } + if(!identical(theBlocks(), pBlocks)){ + theBlocks(pBlocks) + } + } + } if(length(input$messageFromAce$code)>0){ # returning code setCode(input$messageFromAce$code) # only place where request$code is set + sender<-input$messageFromAce$sender # ace returns sender from call to update aceId<-input$messageFromAce$id tabId<-aceID2TabID(aceId) @@ -56,7 +71,7 @@ observeEvent(input$messageFromAce, { } } } - # cat("<----< messageFromAce",'***** sender=',format(input$messageFromAce$sender),"\n\n") + # cat("<----< messageFromAce",'***** sender=',format(input$messageFromAce$sender),"\n\n") }, priority = 90, ignoreNULL = TRUE, ignoreInit = TRUE, label='messageFromAce') diff --git a/inst/App/leftPanel/mid/serverMessageFromAcePageIn.R b/inst/App/leftPanel/mid/serverMessageFromAcePageIn.R index 10be8954..051ff591 100644 --- a/inst/App/leftPanel/mid/serverMessageFromAcePageIn.R +++ b/inst/App/leftPanel/mid/serverMessageFromAcePageIn.R @@ -12,6 +12,7 @@ processMssgFromAceMssgPageIn<-function(sender, mssg){ # cat('getAssetName()=', format(getAssetName()), "\n") } tibs<-getPtDefs()$tib + pruneDeadRowsFromWidgetDB() resetSelectedTibbleName(tibs=tibs, name=name) } else { # else covers: 'cmd.tabChange', # 'cmd.file.new', 'cmd.openFileNow', diff --git a/inst/App/leftPanel/mid/serverMessageFromAcePageOut.R b/inst/App/leftPanel/mid/serverMessageFromAcePageOut.R index d6aad935..e53334b8 100644 --- a/inst/App/leftPanel/mid/serverMessageFromAcePageOut.R +++ b/inst/App/leftPanel/mid/serverMessageFromAcePageOut.R @@ -1,20 +1,23 @@ rmdOut<-function(docFilePath){ - if(usingElectron==TRUE){ - docFilePath<-gsub('~',homeDir,docFilePath) - # TODO:: add check for Pandoc!!! - rmarkdown::render(docFilePath ) - href<-sub('\\.Rmd$','\\.html',docFilePath) - href<-paste0('file://',href) - - sendPtRManagerMessage(sender='cmd.electron', openLink= href) + if (pandoc_available()){ + if(usingElectron==TRUE){ + docFilePath<-gsub('~',homeDir,docFilePath) + # TODO:: add check for Pandoc!!! + rmarkdown::render(docFilePath ) + href<-sub('\\.Rmd$','\\.html',docFilePath) + href<-paste0('file://',href) + + sendPtRManagerMessage(sender='cmd.electron', openLink= href) + } else { + + rmarkdown::render(docFilePath ) + htmlPath<-sub('\\.Rmd$','\\.html',docFilePath) + browseURL(htmlPath) + } } else { - - rmarkdown::render(docFilePath ) - htmlPath<-sub('\\.Rmd$','\\.html',docFilePath) - browseURL(htmlPath) + disable("writeNOpen") # no pandoc } - } diff --git a/inst/App/leftPanel/mid/shinyAce4Ptr.R b/inst/App/leftPanel/mid/shinyAce4Ptr.R index 256bca28..89a04e54 100644 --- a/inst/App/leftPanel/mid/shinyAce4Ptr.R +++ b/inst/App/leftPanel/mid/shinyAce4Ptr.R @@ -30,7 +30,8 @@ initialPtrAceOptions<-function( cursorId=NULL, hotkeys=NULL, docFilePath='?', - initSaved=FALSE + initSaved=FALSE, + link=NULL ) { sanitizeId <- function(id){ @@ -49,7 +50,8 @@ initialPtrAceOptions<-function( autoCompleteList=autoCompleteList, acejs=acejs, docFilePath=docFilePath, - initSaved=initSaved + initSaved=initSaved, + link=link ) rtv<-paste0('ptRaceInit(',toJSON(options),');') # cat('initialPtrAceOptions:: options') @@ -73,7 +75,8 @@ shinyAce4Ptr <- function( cursorId=NULL, hotkeys=NULL, docFilePath=docFilePath, #assigned - initSaved=initSaved #assigned + initSaved=initSaved, #assigned + link=NULL ){ # cat('shinyAce4Ptr:: outputId=',outputId,"\n") @@ -99,7 +102,8 @@ shinyAce4Ptr <- function( autoCompleteList=autoCompleteList, debounce=debounce, selectionId=selectionId, cursorId=cursorId, hotkeys=hotkeys, docFilePath=docFilePath, - initSaved=initSaved + initSaved=initSaved, + link=link ) diff --git a/inst/App/leftPanel/pproj/pprojModalNew.R b/inst/App/leftPanel/pproj/pprojModalNew.R index 7e40b319..1a99eb62 100644 --- a/inst/App/leftPanel/pproj/pprojModalNew.R +++ b/inst/App/leftPanel/pproj/pprojModalNew.R @@ -17,7 +17,8 @@ newProjModal <- function(failed = 0, mssg=NULL, datapath=NULL, projectName=NULL) }, div( textInput(inputId="modalProjName", "Project Name", - value = projectName, + label = gsub('-',' ', projectName), + projectName, placeholder = 'The name of this pointR project' )), #span('Create the project as a subdirectory of:)'), diff --git a/inst/App/leftPanel/pproj/pprojModalNewCntrl.R b/inst/App/leftPanel/pproj/pprojModalNewCntrl.R index b9e47d1c..27b80d5a 100644 --- a/inst/App/leftPanel/pproj/pprojModalNewCntrl.R +++ b/inst/App/leftPanel/pproj/pprojModalNewCntrl.R @@ -1,8 +1,8 @@ # ---beging code to inserted in ptR------------------------------- -newProjShinyCntrlModal <- function(failed = 0, mssg=NULL, datapath=NULL, projectName=NULL, projTemplateName) { +newProjShinyCntrlModal <- function(failed = 0, mssg=NULL, datapath=NULL, projectName=NULL, projTemplatePath) { #shinyDirChoose(input, id='browseForDir', roots=c(wd='~'), filetypes='') - # cat('>----> newProjShinyCntrlModal\n') - requestedProjTemplateName(projTemplateName) + + requestedProjTemplatePath(projTemplatePath) shinyDirChoose(input, id='browseForDir', roots=c(home='~')) observeEvent(input$browseForDir,{ datapath<-parseDirPath(c(home='~'), input$browseForDir) @@ -15,7 +15,7 @@ newProjShinyCntrlModal <- function(failed = 0, mssg=NULL, datapath=NULL, project # cat('>----> modalDialog\n') modalDialog( h4('Create a new Project using the template '), - h2( projTemplateName), + h2( gsub('-', ' ', basename(projTemplatePath))), if(failed==1){ h4(mssg) }, @@ -42,13 +42,14 @@ newProjShinyCntrlModal <- function(failed = 0, mssg=NULL, datapath=NULL, project ) } -requestedProjTemplateName<-reactiveVal("") +requestedProjTemplatePath<-reactiveVal("") #to do: proj name should be restricted to letters, numbers, '.' and spaces. #to do: proj dir should be restricted to letters, numbers, '.' and spaces. observeEvent(input$modalNewShinyCntrlProjOk, { # Check that data object exists and is data frame. - templateName<-requestedProjTemplateName() + templatePath<-requestedProjTemplatePath() + projectName<-input$modalProjName if(!is.null(projectName)){ projectName<-str_trim(projectName) @@ -79,7 +80,7 @@ observeEvent(input$modalNewShinyCntrlProjOk, { } if(failed!=0){ showModal(newProjShinyCntrlModal(failed = failed, mssg=mssg, datapath=datapath, - projectName = projectName, projTemplateName=templateName)) + projectName = projectName, projTemplatePath=templateName)) } else { # try to add file and workspace, if not writable , return fail @@ -91,18 +92,20 @@ observeEvent(input$modalNewShinyCntrlProjOk, { # 3 register in recent projects. # prepare to process - templateName<-requestedProjTemplateName() - templatePath<- projTemplatesPaths[templateName] # the clone path of this project. + templatePath<-requestedProjTemplatePath() + #templatePath<- templateName #projTemplatesPaths[templateName] # the clone path of this project. templateName.pprj<-dir(templatePath,pattern=".pprj$") pathToProjParent<-datapath # input$parentProjDirectoryName # parent directory of new project projName<-gsub('\\.pprj$','',projectName) # the name of of new project - projNameExt<-paste0(projName,'.pprj') + projNameExt<-paste0(projName,'.pprj') # put extension back # 0. close current project closeCurrentProj() - # 1. clone project + sourceProject<- path_join(c(templatePath, templateName.pprj)) + + # 1. clone project fullpathProjName<-copyAndRenameProject( sourceProject= path_join(c(templatePath, templateName.pprj)), targetName=projName, diff --git a/inst/App/leftPanel/pproj/pprojModalSample.R b/inst/App/leftPanel/pproj/pprojModalSample.R deleted file mode 100644 index cdd28616..00000000 --- a/inst/App/leftPanel/pproj/pprojModalSample.R +++ /dev/null @@ -1,103 +0,0 @@ -# ---beging code to inserted in ptR------------------------------- -sampleProjModal <- function(failed = 0, mssg=NULL, datapath=NULL, projectName=NULL) { - - shinyDirChoose(input, id='browseForDir', roots=c(home='~')) - observeEvent(input$browseForDir,{ - datapath<-parseDirPath(c(home='~'), input$browseForDir) - if(length(datapath)==0 || nchar(datapath)==0 ){ - datapath='~' - } else{ - updateTextInput(session,inputId = "parentProjDirectoryName", value=datapath) - } - }) - modalDialog( - h2('Import a new sample project'), - if(failed==1){ - h4(mssg) - }, - div( - h2(paste("Project Name:", projectName)) - ), - #span('Create the project as a subdirectory of:)'), - if(failed==2){ - h4(mssg) - }, - div( style="visibility:hidden", - textInput(inputId="modalProjName", "Project Name", - value = projectName - ) - ) , - div( style="display:inline-block", - textInput(inputId="parentProjDirectoryName", label="Path to project:", - value=datapath, - placeholder = 'The parent directory for this pointR project' - )), - div( style="display:inline-block", - shinyDirButton(id= 'browseForDir', label="browse", title='Browse...', FALSE) - ), - footer = tagList( - modalButton("Cancel"), - actionButton("modalSampleProjOk", "OK") - ) - ) -} - - - -observeEvent(input$modalSampleProjOk, { - # Check that data object exists and is data frame. - - projectName<-input$modalProjName - if(!is.null(projectName)){ - projectName<-str_trim(projectName) - if(nchar(projectName)==0){projectName<-NULL } - } - datapath<-input$parentProjDirectoryName - if(!is.null(datapath)){ - datapath<-str_trim(datapath) - if(nchar(datapath)==0){datapath<-NULL } - } - pathToProjParent<-datapath - pathToProj<-file.path(datapath,projectName) - - if (is.null(projectName) ) { - mssg='Please specify the project name' - showModal(sampleProjModal(failed = 1, mssg=mssg, datapath=datapath, projectName = projectName)) - } else if (is.null(datapath) ) { - mssg='Please specify the project path' - showModal(sampleProjModal(failed = 1, mssg=mssg, datapath=datapath, projectName = projectName)) - } else if(file.access(datapath, mode=0)< 0){ - mssg<- paste('This path specified below does not exist. Please specify a different project path') - showModal(sampleProjModal(failed = 2, mssg=mssg, datapath=datapath, projectName= projectName)) - } else if( file.access(datapath, mode=2)<0 ){ - mssg<- paste('This path specified below is not writable. Please specify a different project path') - showModal(sampleProjModal(failed = 2, mssg=mssg, datapath=datapath, projectName= projectName)) - } else if( file.access(pathToProj, mode=0)==0 ){ - mssg<- paste('Cannot create',pathToProj,'. That dir already exists. Please specify a different project path') - showModal(sampleProjModal(failed = 2, mssg=mssg, datapath=datapath, projectName= projectName)) - } else { - # try to add file and workspace, if not writable , return fail - - projSourcePath<- projSamplesPaths[projectName] - projectName.pprj<-dir(projSourcePath,pattern=".pprj$") - - # 0. close current project - closeCurrentProj() - - # 1. copy project - dir_copy( projSourcePath, pathToProjParent) - - # 2. open copied project - fullpathProjName<-file.path(pathToProjParent, projectName, projectName.pprj) - ptRproj<-read_json(fullpathProjName, simplifyVector = TRUE) - pprj(ptRproj) - - # 3. setup - setUpProj(projName=projectName.pprj, pathToProj=pathToProj, projType='other') - - #invoke startup - requestStartUp() - removeModal() - - } -}) diff --git a/inst/App/leftPanel/pproj/pprojOpen.R b/inst/App/leftPanel/pproj/pprojOpen.R index d8153894..2338294a 100644 --- a/inst/App/leftPanel/pproj/pprojOpen.R +++ b/inst/App/leftPanel/pproj/pprojOpen.R @@ -12,7 +12,7 @@ openProj<-function(projName, pathToProj, projType="generic"){ fullpathProjName=file.path(pathToProj, projName) if(!file.exists(fullpathProjName) ){ err<-paste0(format(fullpathProjName), " not found!" ) - alert(err) + shinyalert("open project Error",err, type="error") return(NULL) } closeCurrentProj() # this needs to complete prior to loading new proj diff --git a/inst/App/leftPanel/pproj/pprojUtil.R b/inst/App/leftPanel/pproj/pprojUtil.R index 45206042..68e6d567 100644 --- a/inst/App/leftPanel/pproj/pprojUtil.R +++ b/inst/App/leftPanel/pproj/pprojUtil.R @@ -11,8 +11,15 @@ # - observeEvent of *customFileDialog* # for the time being we just close closeCurrentProj<-function(){ - storeAssetState() - savePage(input$pages) + log.fin(closeCurrentProj) + # check if current page has a parId + # if so, set current tab to par Id + # + if( is.na(getFileDescriptor(input$pages )$parId )){ + storeAssetState() # this stores the selectedAsset ubti db + savePage(input$pages) # this saves the current page + } + pprj(NULL) if(!is.null(editOption$currentProjectName)){ addToRecentProjects(editOption$currentProjectDirectory, editOption$currentProjectName ) @@ -22,23 +29,32 @@ closeCurrentProj<-function(){ opts<-sapply(opts,unlist, USE.NAMES = T, simplify = F ) writeOptionsJSON(opts) - # close all open tabs - # stopifnot('tabId' %in% names(fileDescDB()) ) - tabIds<-fileDescDB()$tabId + if("parId" %in% names( fileDescDB() )){ + aids<-filter(fileDescDB(), !is.na(parId) & filePath=="?")$tabId + tabIds<-filter(fileDescDB(), is.na(parId) | filePath!="?")$tabId #fileDescDB()$tabId + } else { + aids=NULL + tabIds<-fileDescDB()$tabId + } + if(length(aids)>0){ + tabs<-aceID2TabID(aids) + closeTabsNow(tabs) + } for( tabId in tabIds){ removeTab(inputId = "pages", tabId) } # reinit dbs resetDnippetsDB() - # preProcDB$points<-initialPreprocDB() + preProcScriptDB$points=initialPreProcScriptDB() + preProcScriptDB$attrs= initialPreProcScriptDB() fileDescDB(initialFileDescDB()) svgGridDB( initialSvgGridDB() ) useTribbleFormatDB( initialTribbleDB() ) backDropDB( initialBackDropDB() ) svgGridDB( initialSvgGridDB() ) serverAssetDB$tib<-initialServerAsset() - + log.fout(closeCurrentProj) } # used only by resetShinyFilesIOPaths @@ -81,7 +97,7 @@ resetShinyFilesIOPaths<-function(pathToProj, resources='aux'){ "buttonSnippetImport", "buttonDnippetImport", "buttonPreProcPtImport", "buttonPreprocPtExport", "buttonPreprocAtExport", "buttonPreProcAtImport", - "buttonSvgExport") + "buttonChoiceSetImport", "buttonSvgExport") # first set to root for(id in c(fileIOIds, saveButtonFileNames)){ jscode<-setSfDir(id, path="") @@ -99,6 +115,8 @@ resetShinyFilesIOPaths<-function(pathToProj, resources='aux'){ jscode<-setSfDir(id, path= path_join( c(pathToProj, resourceDir, 'dnds' ))) } else if(id %in% c("buttonSnippetImport")){ jscode<-setSfDir(id, path= path_join( c(pathToProj,resourceDir, 'snip' ))) + } else if(id %in% c("buttonChoiceSetImport")){ + jscode<-setSfDir(id, path= path_join( c(pathToProj,resourceDir, 'choices' ))) } else { jscode<-setSfDir(id, path=pathToProj) } diff --git a/inst/App/leftPanel/serverRequest.R b/inst/App/leftPanel/serverRequest.R index 00fd5264..9d1d1890 100644 --- a/inst/App/leftPanel/serverRequest.R +++ b/inst/App/leftPanel/serverRequest.R @@ -1,13 +1,39 @@ theCode<-reactiveVal("") +theBlocks<-reactiveVal(NULL) +theEnvList<-reactiveVal(list()) #or NULL? request<-reactiveValues( - sender=NULL, + cmd=NULL, tabs=NULL, - trigger=0 + trigger=0, + predoc="" ) +getWDCmd<-reactive({ + log.fin(getWDCmd) + dpath<-getDirPath() + if(identical(dpath, '~/.ptR')){ + dpath<-'~' + } + dd<-paste0('\nsetwd("',dpath,'")\n\n') + log.fout(getWDCmd) + dd +}) + +getEnvList<-function(){ + wd<-getWDCmd() + pcode<-theBlocks() + initialEnv=new.env() + if(!is.null(pcode) && pcode!=""){ + pcode=paste(wd,pcode,sep="\n") + } else { + pcode<-wd + } + eval(parse(text=pcode),initialEnv) + initialEnv +} trigger<-reactiveValues( redraw=0, @@ -29,11 +55,11 @@ getCode4RenderingTransform<-eventReactive( trigger$redraw, { }) -setTabRequest<-function(sender, tabs){ - # if(length(sender)==1 && length(tabs)>1){ - # sender<-rep_len(sender,length(tabs) ) +setTabRequest<-function(cmd, tabs){ + # if(length(cmd)==1 && length(tabs)>1){ + # cmd<-rep_len(cmd,length(tabs) ) # } - request$sender<-sender + request$cmd<-cmd request$tabs<-tabs request$trigger<-sample(10^6,1) } @@ -49,13 +75,7 @@ peekTabRequest<-function(){ } peekTabCmd<-function(){ - request$sender -} - - -clearRequest<-function( ){ - request$sender<-NULL - request$tags<-list() + request$cmd } requestStartUp<-function(){ @@ -66,10 +86,18 @@ peekTab<-reactive( {request$tabs[1]} ) popTab<-reactive({ tab<-request$tabs[1] request$tabs<-request$tabs[-1] - # ????? if length(tabs is 0, remove sender?) + # ????? if length(tabs is 0, remove cmd?) tab }) +setBlocks<-function(blocks){ # not used??? + theBlocks(blocks) +} + +getBlocks<-reactive({ # not used??? + theBlocks() +}) + setCode<-function(code){ theCode(code) } diff --git a/inst/App/leftPanel/tabs/serverFileTabs.R b/inst/App/leftPanel/tabs/serverFileTabs.R index 8ea1a8cc..7f18c68c 100644 --- a/inst/App/leftPanel/tabs/serverFileTabs.R +++ b/inst/App/leftPanel/tabs/serverFileTabs.R @@ -47,6 +47,25 @@ closeTabNow<-function(tabId2X){ removeTab(inputId = "pages", tabId2X) } +closeTabsNow<-function(tabIds2Close){ + if(length(tabIds2Close)>0){ + serverAssetDB$tib<-filter(serverAssetDB$tib, !(tabId %in% tabIds2Close)) + db<-widgetDB() + db<-filter(db, !(tabId %in% tabIds2Close)) + widgetDB(db) + fdDB<-fileDescDB() + fdDB<-filter(fdDB, !(tabId %in% tabIds2Close)) + fileDescDB(fdDB) + path=getWorkSpaceDir() + for(id in tabIds2Close){ + pth<-paste0(path,"/",id,".rda") + file.remove(pth) + removeTab(inputId = "pages", id) + } + } + + +} @@ -54,18 +73,24 @@ closeTabNow<-function(tabId2X){ # TODO!!!! , add input parameters for: autocomplete # fontsize should be read from options -addFileTab<-function(title, txt, docFilePath='?', mode='ptr', fileSaveStatus=FALSE){ +addFileTab<-function(title, txt, docFilePath='?', mode='ptr', fileSaveStatus=FALSE, link=NULL, parMode=NA){ log.fin(addFileTab) tabId<-getNextTabId() if(is.null(tabId)){ cat("tabId is null\n"); browser() } #should never happen - addFileDesc(pageId=tabId, docFilePath=docFilePath, fileSaveStatus, fileMode=mode) + parId=NULL + if(!is.null(link)){ + parId<-unlist(strsplit(link,'\\.'))[[1]] + } + cat(format(parMode)) + addFileDesc(pageId=tabId, docFilePath=docFilePath, fileSaveStatus, fileMode=mode, parId, parMode) setUseTribble( pageId=tabId, value=TRUE) addNewPage2dnippetsDB(tabId) aceId<-newPage(tabId=tabId, title=title, txt=txt, docFilePath=docFilePath, mode=mode, - fileSaveStatus=fileSaveStatus) + fileSaveStatus=fileSaveStatus, + link=link) #sendFileTabsMessage(tabId=pageId, sender='savedStatus', saveStatus=fileSaveStatus,resize=runif(1)) sendFileTabsMessage(resize=runif(1)) @@ -93,8 +118,8 @@ observeEvent(input$pages,{ # updated by scrollManager and relays sender with tabs to request observeEvent(input$tabManager,{ tabs=unlist(input$tabManager$tabs) - sender=input$tabManager$sender - setTabRequest(sender=sender, tabs=tabs) + cmd=input$tabManager$sender + setTabRequest(cmd=cmd, tabs=tabs) }, label='tabManager') # request$tabs is updated by either @@ -131,3 +156,49 @@ observeEvent(c(request$trigger,request$tabs), { } }, label='request-tabs-trigger') +observeEvent(input$messageContextMenu, { + cmd=input$messageContextMenu$cmd + # cat('cmd=') + # cat(format(cmd)) + parMode<-input$messageContextMenu$parMode + # cat('\ninput$messageContextMenu$parMode return value=') + # cat(format(parMode)) + # cat("\n") + if(cmd=="newTab"){ + # print(start_row) + # print(end_row) + start_row=input$messageContextMenu$start_row + end_row=input$messageContextMenu$end_row + src<-input$messageContextMenu$code + rid<-input$messageContextMenu$id + tabName<-input$messageContextMenu$label + rmdAceId<-tabID2aceID(input$pages) + link<-paste(rmdAceId,rid, sep=".") + + # we update Ace with code + # + all prior code as a hidden portion + # and keep a hidden copy of full text for later reinsertion. + # BUT widget handler then has a problem, would need to know which ptR we are refering to. + if(tabName==""){ + tabName<-getNextAnonymousFileName() + } + tabId<-addFileTab(title=tabName, txt=src, docFilePath="?", mode='ptr', fileSaveStatus=FALSE, link=link, parMode=parMode) + # + aceId<-tabID2aceID(tabId) + # alternatively set ace content of to code, and save full txt somewhere + + mssg$error<-"" + } else if(cmd=="openTab"){ + id<-input$messageContextMenu$id + tabId=aceID2TabID(id) + + updateTabsetPanel(session, "pages", selected = tabId) + # change to tabId + #sendFileTabsMessage(selected=tabId, resize=runif(1)) + + #setTabRequest(cmd="tabChange", tabs=tabId) + + } + + # log.fout(cmdFileNewPtR) +}) \ No newline at end of file diff --git a/inst/App/leftPanel/tabs/serverNewPage.R b/inst/App/leftPanel/tabs/serverNewPage.R index 287bd476..29e93cb9 100644 --- a/inst/App/leftPanel/tabs/serverNewPage.R +++ b/inst/App/leftPanel/tabs/serverNewPage.R @@ -1,7 +1,7 @@ # gets what we need from fileDescDB() -newPage<-function(tabId, title, txt, docFilePath, mode, fileSaveStatus ){ +newPage<-function(tabId, title, txt, docFilePath, mode, fileSaveStatus, link=NULL ){ # fileSaveStatus is boolean log.fin(newPage) if(is.null(tabId)){ @@ -16,6 +16,8 @@ newPage<-function(tabId, title, txt, docFilePath, mode, fileSaveStatus ){ } else { divClass="cAceRmdContainer" } + # print("**** newPage link") + # print(link) appendTab( inputId = "pages", select=TRUE, tabPanel( @@ -38,7 +40,8 @@ newPage<-function(tabId, title, txt, docFilePath, mode, fileSaveStatus ){ NULL }, docFilePath =docFilePath, - initSaved =fileSaveStatus + initSaved =fileSaveStatus, + link=link ) ), value=tabId diff --git a/inst/App/leftPanel/toolbar/cmdHToolBar.R b/inst/App/leftPanel/toolbar/cmdHToolBar.R index 00ee137f..57cdd48d 100644 --- a/inst/App/leftPanel/toolbar/cmdHToolBar.R +++ b/inst/App/leftPanel/toolbar/cmdHToolBar.R @@ -4,7 +4,14 @@ observeEvent( input$tbNewFile ,{ }, ignoreInit = TRUE) observeEvent( input$tbSaveFile ,{ - cmdFileSave() + tabId<-input$pages + docFilePath<-getFileDescriptor(tabId )$filePath + if(!is.null(docFilePath) && !docFilePath=='?'){ + cmdFileSave() + } else { + cmdFileSaveAs() + } + }, ignoreInit = TRUE) observeEvent( input$tbCloseFile ,{ @@ -37,7 +44,7 @@ hBaRR<-reactiveValues( observers=list() ) -#observeEvent( request$sender, { +#observeEvent( request$cmd, { observeEvent( getCode(), { genTBObserver<-function(tbId, cmd){ return(observeEvent( diff --git a/inst/App/projectTemplates/New-Basic-Project/.DS_Store b/inst/App/projectTemplates/New-Basic-Project/.DS_Store new file mode 100644 index 00000000..5456890f Binary files /dev/null and b/inst/App/projectTemplates/New-Basic-Project/.DS_Store differ diff --git a/inst/App/projectTemplates/New-Basic-Project/.workspace/PTR-TABID1bc24c47730d.rda b/inst/App/projectTemplates/New-Basic-Project/.workspace/PTR-TABID1bc24c47730d.rda new file mode 100644 index 00000000..960c7c4a Binary files /dev/null and b/inst/App/projectTemplates/New-Basic-Project/.workspace/PTR-TABID1bc24c47730d.rda differ diff --git a/inst/App/projectTemplates/New-Basic-Project/.workspace/currentTab.rda b/inst/App/projectTemplates/New-Basic-Project/.workspace/currentTab.rda new file mode 100644 index 00000000..4f407ec3 Binary files /dev/null and b/inst/App/projectTemplates/New-Basic-Project/.workspace/currentTab.rda differ diff --git a/inst/App/sampleProjects/autoArrow/autoArrow.pprj b/inst/App/projectTemplates/New-Basic-Project/New-Basic-Project.pprj similarity index 60% rename from inst/App/sampleProjects/autoArrow/autoArrow.pprj rename to inst/App/projectTemplates/New-Basic-Project/New-Basic-Project.pprj index a475338b..51a4435c 100644 --- a/inst/App/sampleProjects/autoArrow/autoArrow.pprj +++ b/inst/App/projectTemplates/New-Basic-Project/New-Basic-Project.pprj @@ -1,9 +1,9 @@ { "pathToProj": [ - "~/BB/autoArrow" + "~/A/New-Basic-Project" ], "projName": [ - "autoArrow.pprj" + "New-Basic-Project.pprj" ], "projType": [ "generic" diff --git a/inst/App/projectTemplates/New-Basic-Project/aux/.DS_Store b/inst/App/projectTemplates/New-Basic-Project/aux/.DS_Store new file mode 100644 index 00000000..c194fd9d Binary files /dev/null and b/inst/App/projectTemplates/New-Basic-Project/aux/.DS_Store differ diff --git a/inst/App/projectTemplates/New-Basic-Project/aux/dnds/fill.dnds b/inst/App/projectTemplates/New-Basic-Project/aux/dnds/fill.dnds new file mode 100644 index 00000000..baddd304 --- /dev/null +++ b/inst/App/projectTemplates/New-Basic-Project/aux/dnds/fill.dnds @@ -0,0 +1,143 @@ +--- +title: "Dnd Snippet" +author: "Anonymous" +date: "TODAY" +output: dnd_snippet +--- + +- Individual drippets are seperate by lines consisting of three or more stars (*) +- Each drippet consists of 3 entries, with each entry having a title and a value (block) + - The title consists of a single line followed by a colon (:) + - titles are *POPUP*, *SNIPPET*, *SVGR* + - The values are blocks defined by 3 backtics *````* +- Two drippets are shown below to help you get started + + +********************* + + +POPUP +``` +Linear Gradient +``` +SNIPPET +``` +linearGradient( + xy1=${1:c(0,0)}, + xy2=${2:c(0,1)}, + colors=${3:c('#00AAAA', '#00000')}, + gradientUnits=${0:"objectBoundingBox"} +) +``` +SVGR +``` +library(svgR) +WH<-c(48,32) +ptR<-list( + x=matrix(0,2,0) +) +svgR(wh=WH, + rect( + cxy=WH/2, + wh=WH*c(.8,.8), + fill=linearGradient( + xy1=c(0,0), + xy2=c(0,1), + colors=c('#00AAAA', '#FFFFFF') + ), + stroke='none', + stroke.width=1 + ) +) +``` +********************* + +POPUP +``` +Radial Gradient +``` +SNIPPET +``` +radialGradient( + cxy=${1:c(.5,.7)*.5}, + fxy=${2:c(1,1)*.5}, + colors=${3:c('#FFFFFF', '#00AAAA')}, + gradientUnits=${0:"objectBoundingBox"} +) +``` +SVGR +``` +library(svgR) +WH<-c(48,32) +ptR<-list( + x=matrix(0,2,0) +) +X=c(.2,.4,.6,.8) +svgR(wh=WH, + rect( + cxy=WH/2, + wh=WH*c(.8,.8), + fill=radialGradient( + cxy=c(.5,.7), + fxy=c(1,1)*.5, + colors=c('#FFFFFF', '#00AAAA') + ), + stroke='none', + stroke.width=1 + ) +) +``` +****************** +********************* + +POPUP +``` +Pattern +``` +SNIPPET +``` +pattern( + patternUnits=${1:"userSpaceOnUse"}, + xy=${2:c(1,1)*0}, + wh=${3:c(1,1)*min(WH)*.2}, + ${0:circle( + cxy=c(1,1)*min(WH)*.1, + r=min(WH)*.1, + stroke.width=1, + fill='none', + stroke='#00FFFF' + )} +) +``` +SVGR +``` +library(svgR) +WH<-c(48,32) +ptR<-list( + x=matrix(0,2,0) +) +X=c(.2,.4,.6,.8) +W<-.9*min(WH) +svgR(wh=WH, + rect( + cxy=WH/2, + wh=W*c(1,1), + fill=pattern( + patternUnits="userSpaceOnUse", + xy=c(1,1)*0, + wh=c(1,1)*W*.2, + circle( + cxy=c(1,1)*W*.1, + r=W*.1, + stroke.width=1, + fill='none', + stroke='#00FFFF' + ) + ), + stroke='none', + stroke.width=1 + ) +) +``` +****************** + diff --git a/inst/App/sampleProjects/shinyDialInputOptimized/aux/dnds/sampleShapes.dnds b/inst/App/projectTemplates/New-Basic-Project/aux/dnds/sampleShapes.dnds similarity index 80% rename from inst/App/sampleProjects/shinyDialInputOptimized/aux/dnds/sampleShapes.dnds rename to inst/App/projectTemplates/New-Basic-Project/aux/dnds/sampleShapes.dnds index 0034e180..45f5975b 100644 --- a/inst/App/sampleProjects/shinyDialInputOptimized/aux/dnds/sampleShapes.dnds +++ b/inst/App/projectTemplates/New-Basic-Project/aux/dnds/sampleShapes.dnds @@ -23,7 +23,7 @@ SNIPPET ``` circle( cxy=${1:WH/2}, - r=${2:WH[2]/3}, + r=${2:min(WH)/3}, stroke='black', fill=${3:'none'} )${0:} @@ -31,16 +31,15 @@ circle( SVGR ``` library(svgR) -WH<-c(48,32) + ptR<-list( x=matrix(0,2,0) ) -svgR(wh=WH, +svgR( #your custom code goes here circle( cxy=WH/2, r=WH[2]/3, - stroke='#00FFFF', stroke.width=2, fill='none' ) @@ -66,16 +65,15 @@ ellipse( SVGR ``` library(svgR) -WH<-c(48,32) + ptR<-list( x=matrix(0,2,0) ) -svgR(wh=WH, +svgR( #your custom code goes here ellipse( cxy=WH/2, rxy=c(.3,.2)*WH, - stroke='#00FFFF', stroke.width=2, fill='none' ) @@ -103,17 +101,16 @@ rect( SVGR ``` library(svgR) -WH<-c(48,32) + ptR<-list( x=matrix(0,2,0) ) -svgR(wh=WH, - line(xy1=c(.5,0)*WH, xy2=c(.5,1)*WH, stroke.dasharray=2, stroke="#00FFFF"), - line(xy1=c(0,.5)*WH, xy2=c(1,.5)*WH, stroke.dasharray=2, stroke="#00FFFF"), +svgR( + line(xy1=c(.5,0)*WH, xy2=c(.5,1)*WH, stroke.dasharray=2), + line(xy1=c(0,.5)*WH, xy2=c(1,.5)*WH, stroke.dasharray=2), rect( xy=WH/2, wh=c(.4,.2)*WH, - stroke='#00FFFF', stroke.width=2, fill='none' ) @@ -140,17 +137,16 @@ rect( SVGR ``` library(svgR) -WH<-c(48,32) + ptR<-list( x=matrix(0,2,0) ) svgR(wh=WH, - line(xy1=c(.5,0)*WH, xy2=c(.5,1)*WH, stroke.dasharray=2, stroke="#00FFFF"), - line(xy1=c(0,.5)*WH, xy2=c(1,.5)*WH, stroke.dasharray=2, stroke="#00FFFF"), + line(xy1=c(.5,0)*WH, xy2=c(.5,1)*WH, stroke.dasharray=2), + line(xy1=c(0,.5)*WH, xy2=c(1,.5)*WH, stroke.dasharray=2), rect( cxy=WH/2, wh=c(.4,.2)*WH, - stroke='#00FFFF', stroke.width=2, fill='none' ) @@ -173,15 +169,14 @@ line( SVGR ``` library(svgR) -WH<-c(48,32) + ptR<-list( x=matrix(0,2,0) ) -svgR(wh=WH, +svgR( line( xy1=c(.2,0.8)*WH, xy2=c(.8,0.2)*WH, - stroke='#00FFFF', stroke.width=2 ) ) @@ -197,14 +192,14 @@ SNIPPET polyline( points=${1:WH*matrix(c(.25,.25,.5,.5,.75,.25),2)}, stroke=${2:'black'}, - stroke.width=${2:1}, - fill=${3:'none'} + stroke.width=${3:1}, + fill=${4:'none'} )${0:} ``` SVGR ``` library(svgR) -WH<-c(48,32) + ptR<-list( x=matrix(0,2,0) ) @@ -212,7 +207,6 @@ svgR(wh=WH, polyline( points=WH*matrix(c(.25,.25,.5,.8,.75,.25),2), stroke.width=2, - stroke='#00FFFF', fill='none' ) ) @@ -228,21 +222,20 @@ SNIPPET polygon( points=${1:WH*matrix(c(.25,.75,.5,.5,.75,.75),2)}, stroke=${2:'black'}, - stroke.width=${2:1}, - fill=${3:'none'} + stroke.width=${3:1}, + fill=${4:'none'} )${0:} ``` SVGR ``` library(svgR) -WH<-c(48,32) + ptR<-list( x=matrix(0,2,0) ) -svgR(wh=WH, +svgR( polygon( points=WH*matrix(c(.25,.75,.5,.25,.75,.75),2), - stroke='#00FFFF', stroke.width=2, fill='none' ) @@ -267,17 +260,16 @@ text( SVGR ``` library(svgR) -WH<-c(48,32) + ptR<-list( x=matrix(0,2,0) ) -svgR(wh=WH, - line(xy1=c(.5,0)*WH, xy2=c(.5,1)*WH, stroke.dasharray=2, stroke="#00FFFF"), - line(xy1=c(0,.5)*WH, xy2=c(1,.5)*WH, stroke.dasharray=2, stroke="#00FFFF"), +svgR( + line(xy1=c(.5,0)*WH, xy2=c(.5,1)*WH, stroke.dasharray=2), + line(xy1=c(0,.5)*WH, xy2=c(1,.5)*WH, stroke.dasharray=2), text( 'Text', xy=WH/2, - stroke='#00FFFF', font.size=10, fill='#00FFFF' ) @@ -302,17 +294,16 @@ SNIPPET SVGR ``` library(svgR) -WH<-c(48,32) + ptR<-list( x=matrix(0,2,0) ) -svgR(wh=WH, - line(xy1=c(.5,0)*WH, xy2=c(.5,1)*WH, stroke.dasharray=2, stroke="#00FFFF"), - line(xy1=c(0,.5)*WH, xy2=c(1,.5)*WH, stroke.dasharray=2, stroke="#00FFFF"), +svgR( + line(xy1=c(.5,0)*WH, xy2=c(.5,1)*WH, stroke.dasharray=2), + line(xy1=c(0,.5)*WH, xy2=c(1,.5)*WH, stroke.dasharray=2), text( 'Text', cxy=WH/2, - stroke='#00FFFF', font.size=10, fill='#00FFFF' ) @@ -329,7 +320,7 @@ SNIPPET path( d=list( M=${1:c(.5,.2)*WH}, - A=${2:c(2.3*WH, 180,1,0,c(.8,.5)*WH)} + A=${2:c(.3*WH, 180,1,0,c(.8,.5)*WH)} ), stroke=${3:'#0000FF'}, stroke.width=${4:2}, @@ -339,21 +330,19 @@ SNIPPET SVGR ``` library(svgR) -WH<-c(48,32) -# Defined by mouse: edit with care! + ptR<-list( x=tribble( ~points, - matrix(NA,2,0) + matrix(0,2,0) ) ) -svgR(wh=WH, +svgR( path( d=list( M=c(.5,.2)*WH, A=c(.3*WH, 180,1,0,c(.8,.5)*WH) ), - stroke='#00FFFF', stroke.width=2, fill='none' ) @@ -372,7 +361,7 @@ path( ${1:M=c(.2,.2)*WH,} Q=${2:c( c(.5,1.5),c(.8,.2))*WH} ), - stroke=${3:'#000FF'}, + stroke=${3:'#0000FF'}, stroke.width=${4:1}, fill=${5:'none'} )${0:} @@ -380,21 +369,20 @@ path( SVGR ``` library(svgR) -WH<-c(48,32) + # Defined by mouse: edit with care! ptR<-list( x=tribble( ~points, - matrix(NA,2,0) + matrix(0,2,0) ) ) -svgR(wh=WH, +svgR( path( d=list( M=c(.2,.2)*WH, Q=c( c(.5,1.5)*WH,c(.8,.2)*WH) ), - stroke='#00FFFF', stroke.width=2, fill='none' ) @@ -422,22 +410,21 @@ path( SVGR ``` library(svgR) -WH<-c(48,32) + # Defined by mouse: edit with care! ptR<-list( x=tribble( ~points, - matrix(NA,2,0) + matrix(0,2,0) ) ) -svgR(wh=WH, +svgR( path( d=list( M=c(.3,.1)*WH, Q=c( c(1,.7),c(.5,.7))*WH, T=c(.7,.1)*WH ), - stroke='#00FFFF', stroke.width=2, fill='none' ) @@ -464,18 +451,17 @@ path( SVGR ``` library(svgR) -WH<-c(48,32) + ptR<-list( x=matrix(0,2,0) ) -svgR(wh=WH, +svgR( #your custom code goes here path( d=list( M=c(.2,.9)*WH, C=c( c(.3,-1),c(.7,2), c(.8,.2))*WH ), - stroke='#00FFFF', stroke.width=2, fill='none' ) @@ -504,11 +490,11 @@ path( SVGR ``` library(svgR) -WH<-c(48,32) + ptR<-list( x=matrix(0,2,0) ) -svgR(wh=WH, +svgR( #your custom code goes here path( d=list( @@ -516,7 +502,6 @@ svgR(wh=WH, C=c( c(.4,.0),c(.4,.8), c(.5,.8))*WH, S=c( c(.6,.0),c(.8,.6))*WH ), - stroke='#00FFFF', stroke.width=2, fill='none' ) diff --git a/inst/App/projectTemplates/reactiveChartBldr/.workspace/PTR-TABID4b7e614fe62f.rda b/inst/App/projectTemplates/reactiveChartBldr/.workspace/PTR-TABID4b7e614fe62f.rda deleted file mode 100644 index 39b3fc80..00000000 Binary files a/inst/App/projectTemplates/reactiveChartBldr/.workspace/PTR-TABID4b7e614fe62f.rda and /dev/null differ diff --git a/inst/App/projectTemplates/reactiveChartBldr/.workspace/currentTab.rda b/inst/App/projectTemplates/reactiveChartBldr/.workspace/currentTab.rda deleted file mode 100644 index 517a6962..00000000 Binary files a/inst/App/projectTemplates/reactiveChartBldr/.workspace/currentTab.rda and /dev/null differ diff --git a/inst/App/projectTemplates/reactiveChartBldr/.workspace/loadedDnippets.rda b/inst/App/projectTemplates/reactiveChartBldr/.workspace/loadedDnippets.rda deleted file mode 100644 index e5eedcc7..00000000 Binary files a/inst/App/projectTemplates/reactiveChartBldr/.workspace/loadedDnippets.rda and /dev/null differ diff --git a/inst/App/projectTemplates/reactiveChartBldr/aux/dnds/reactiveFlow.dnds b/inst/App/projectTemplates/reactiveChartBldr/aux/dnds/reactiveFlow.dnds deleted file mode 100644 index 7363f7bc..00000000 --- a/inst/App/projectTemplates/reactiveChartBldr/aux/dnds/reactiveFlow.dnds +++ /dev/null @@ -1,166 +0,0 @@ ---- -title: "Dnd Snippet" -author: "Anonymous" -date: "TODAY" -output: dnd_snippet ---- - -- Individual drippets are seperate by lines consisting of three or more stars (*) -- Each drippet consists of 3 entries, with each entry having a title and a value (block) - - The title consists of a single line followed by a colon (:) - - titles are *POPUP*, *SNIPPET*, *SVGR* - - The values are blocks defined by 3 backtics *````* -- Two drippets are shown below to help you get started - - -********************* - - -POPUP -``` -Block -``` -SNIPPET -``` - pmap(ptR$${1:block}, block) -``` -SVGR -``` -library(svgR) -WH<-c(48,32) -ptR<-list( - x=matrix(0,2,0) -) -svgR(wh=WH, fill='none', stroke='#00FFFF', stroke.width=2, - rect( - cxy=WH/2, - wh=WH/1.5 - - ), - text(cxy=WH/2, 'B', fill='#00FFFF') -) -``` -********************* - -POPUP -``` -reactiveSource -``` -SNIPPET -``` -pmap(ptR$${1:source}, reactiveSource) -``` -SVGR -``` -library(svgR) -WH<-c(48,32) -xy<-c(.2,.2)*WH -wwh<-c(.6,.6)*WH -m<-c('M',xy) -dz<-wwh[2]/2 -dx<-wwh[1]-dz -polyPortion<-c('l', dx,0, dz,dz, -dz,dz, -dx, 0 ) -d<-c(m, polyPortion, 'Z') - -svgR(wh=WH, stroke.width=2, stroke="#00FFFF", fill="none", - g( - path(d=d), - text(cxy=WH/2, 'S') - ) -) -``` -****************** -POPUP -``` -reactiveObserver -``` -SNIPPET -``` -pmap(ptR$${1:observer}, reactiveObserver) -``` -SVGR -``` -library(svgR) -WH<-c(48,32) -xy<-c(.2,.2)*WH -wwh<-c(.6,.6)*WH -m<-c('M',xy) -dz<-wwh[2]/2 -dx<-wwh[1]-dz -polyPortion<-c('l', dx,0, dz,dz, -dz,dz, -dx, 0 ) -d<-c(m, polyPortion, 'Z') - - - m<-c('M',xy+c(dz,0)) - polyPortion<-c('l', dx,0, 0,2*dz, -dx, 0 ) - arcPortion<-c('a', c(dz,dz), 180, 1,1, c(0, -2*dz)) - d<-c(m, polyPortion, arcPortion) -svgR(wh=WH, stroke.width=2, stroke="#00FFFF", fill="none", - g( - path(d=d ), - text(cxy=xy+wwh/2, "O") - ) -) -``` -****************** -POPUP -``` -reactiveExpression -``` -SNIPPET -``` -pmap(ptR$${1:expression}, reactiveExpression) -``` -SVGR -``` -library(svgR) -WH<-c(48,32) -xy<-c(.2,.2)*WH -wwh<-c(.5,.6)*WH -m<-c('M',xy) -dz<-wwh[2]/2 -dx<-wwh[1]-dz -polyPortion<-c('l', dx,0, dz,dz, -dz,dz, -dx, 0 ) -d<-c(m, polyPortion, 'Z') - - - m<-c('M',xy+c(dz,0)) - polyPortion<-c('l', dx,0, dz,dz, -dz,dz, -dx, 0 ) - arcPortion<-c('a', c(dz,dz), 180, 1,1, c(0, -2*dz)) - d<-c(m, polyPortion, arcPortion) - -svgR(wh=WH, stroke.width=2, stroke="#00FFFF", fill="none", - g( - path(d=d ), - text(cxy=WH/2, "E") - ) -) -``` -****************** -POPUP -``` -Arrow -``` -SNIPPET -``` -pmap(ptR$${1:arrows}, arrow) -``` -SVGR -``` -library(svgR) -WH<-c(48,32) -stroke="#00FFFF" -svgR(wh=WH, stroke.width=2, stroke="#00FFFF", fill="none", - path( - d=c("M", c(.1,.7)*WH, "L", c(c(.5,.7), c(.5,.5), c(.8,.5))*WH), - fill='none', stroke=stroke, - marker.end= marker( viewBox=c(0, -1, 12, 12), refXY=c(9,5), stroke=stroke, fill=stroke, - markerWidth=4, markerHeight=4, orient="auto", - path( d=c("M", 0, 0, "L", 10, 5, "L", 0, 10, "z") ) - - ) - ) -) -``` -****************** - diff --git a/inst/App/projectTemplates/reactiveChartBldr/aux/preprocPts/snapTo50.R b/inst/App/projectTemplates/reactiveChartBldr/aux/preprocPts/snapTo50.R deleted file mode 100644 index 5728bffa..00000000 --- a/inst/App/projectTemplates/reactiveChartBldr/aux/preprocPts/snapTo50.R +++ /dev/null @@ -1,32 +0,0 @@ -preprocPts<-list( - onNewPt = function( pt, context, WH, keys){ - # template for point insertion precprossing - - pt<-getPoint() # pt contains coordinates derived from the mouse click - - # apply your point manipulations here - pt<-50*round(pt/50) - tibs<-insertPoint(pt=pt, context=context ) - tibs # always return tibs - }, - onMovePt = function( pt, context, WH, keys){ - # template for point insertion precprossing - - pt<-getPoint() # pt contains coordinates derived from the mouse move - - #apply your point manipulations here - pt<-50*round(pt/50) - tibs<-movePoint(pt=pt, context=context ) - tibs # always return tibs - }, - onMoveMat = function( pt, context, WH, keys){ - # template for point insertion precprossing - - dxy=getDxy() # pt contains coordinates derived from the mouse move - - #apply your point manipulations here - dxy<-50*round(dxy/50) - tibs<-moveMatrix(dxy=dxy, context=context ) - tibs # always return tibs - } -) diff --git a/inst/App/projectTemplates/reactiveChartBldr/develObjects.R b/inst/App/projectTemplates/reactiveChartBldr/develObjects.R deleted file mode 100644 index b2e3ffe2..00000000 --- a/inst/App/projectTemplates/reactiveChartBldr/develObjects.R +++ /dev/null @@ -1,131 +0,0 @@ -library(svgR) -library(tidyverse) - - - -block %=2 ){ - xy<-apply(points,1,min) - wh<-abs(apply(points,1,diff)) - g( - rect(xy=xy, wh=wh, fill=fill, stroke=stroke, ...), - text(stroke=stroke, cxy=xy+wh/2, label, ...) - - ) - } else{ - NULL - } -} - -reactiveSource %=2 ){ - xy<-apply(points,1,min) - wh<-abs(apply(points,1,diff)) - - m<-c('M',xy) - dz<-wh[2]/2 - dx<-wh[1]-dz - - polyPortion<-c('l', dx,0, dz,dz, -dz,dz, -dx, 0 ) - d<-c(m, polyPortion, 'Z') - g( - path(d=d, fill=fill, stroke=stroke), - text(cxy=xy+wh/2, label) - ) - } else{ - NULL - } -} - - -reactiveObserver %=2 ){ - xy<-apply(points,1,min) - wh<-abs(apply(points,1,diff)) - - dz<-wh[2]/2 - dx<-wh[1]-dz - m<-c('M',xy+c(dz,0)) - polyPortion<-c('l', dx,0, 0,2*dz, -dx, 0 ) - arcPortion<-c('a', c(dz,dz), 180, 1,1, c(0, -2*dz)) - d<-c(m, polyPortion, arcPortion) - g( - path(d=d, fill=fill, stroke=stroke, ... ), - text(cxy=xy+wh/2, label) - ) - } else{ - NULL - } -} - -reactiveExpression %=2 ){ - xy<-apply(points,1,min) - wh<-abs(apply(points,1,diff)) - - - dz<-wh[2]/2 - dx<-wh[1]-2*dz - m<-c('M',xy+c(dz,0)) - polyPortion<-c('l', dx,0, dz,dz, -dz,dz, -dx, 0 ) - arcPortion<-c('a', c(dz,dz), 180, 1,1, c(0, -2*dz)) - d<-c(m, polyPortion, arcPortion) - g( - path(d=d, fill=fill, stroke=stroke, ... ), - text(cxy=xy+wh/2, label) - ) - } else{ - NULL - } -} - -arrow %=2 ){ - x<-points - nx<-length(x) - if(nx<4){ - return(NULL) - } - n<-ncol(x) - if(n==2){ - return(path(d=c("M", x[,1], "L", x[,n]), ...)) - } - - dv<-x[,-n]-x[,-1] - d<-apply( dv ,2, function(x)sqrt(sum(x)^2) ) - lambda<-sapply(r/d, function(x)min(x,.5)) - - m<- n-1 - if(m==2){ - mA<-matrix(c(lambda[1],1-lambda[1]),2,1) - mB<-matrix(c(1-lambda[2],lambda[2]),2,1) - } else { - mA<- rbind(diag(lambda[-m]),0) + rbind(0,diag(1-lambda[-m])) - mB<- rbind(0,diag(lambda[-1])) + rbind(diag(1-lambda[-1]),0) - } - a<-x[,-n]%*%mA - b<-x[,-1]%*%mB - rL<-rep("L", n-2) - rQ<-rep("Q", n-2) - if(m==2){ - rr<-c(rL,a,rQ,x[,2],b) - } else { - rr<-rbind(rL, a, rQ, x[,-c(1,n)], b) - } - path( - d=c("M", x[,1], rr, "L", x[,n]), - fill='none', stroke=stroke, - marker.end= marker( viewBox=c(0, 0, 10, 10), refXY=c(9,5), stroke=stroke, fill=stroke, - markerWidth=6, markerHeight=6, orient="auto", - path( d=c("M", 0, 0, "L", 10, 5, "L", 0, 10, "z") ) - - ), - ...) - } else{ - NULL - } -} - - - - diff --git a/inst/App/projectTemplates/reactiveChartBldr/main.R b/inst/App/projectTemplates/reactiveChartBldr/main.R deleted file mode 100644 index e966c165..00000000 --- a/inst/App/projectTemplates/reactiveChartBldr/main.R +++ /dev/null @@ -1,34 +0,0 @@ -library(svgR) -library(tidyverse) -WH<-c(800,800) - -source('develObjects.R') - - -#Defined by mouse: edit with care! -ptR<-list( - source=tibble( - points = list(matrix(0,2,0)) - ), - observer=tibble( - points = list(matrix(0,2,0)) - ), - expression=tibble( - points = list(matrix(0,2,0)) - ), - arrows=tibble( - points = list(matrix(0,2,0)) - ), - block=tibble( - points = list(matrix(0,2,0)) - ) -) - -svgR(wh=WH, - NULL # your custom code goes here -) - - - - - diff --git a/inst/App/projectTemplates/reactiveChartBldr/reactiveChartBldr.pprj b/inst/App/projectTemplates/reactiveChartBldr/reactiveChartBldr.pprj deleted file mode 100644 index 89500b9f..00000000 --- a/inst/App/projectTemplates/reactiveChartBldr/reactiveChartBldr.pprj +++ /dev/null @@ -1,12 +0,0 @@ -{ - "pathToProj": [ - "/home/sup/AA/reactiveChartBldr" - ], - "projName": [ - "reactiveChartBldr.pprj" - ], - "projType": [ - "generic" - ] -} - diff --git a/inst/App/projectTemplates/shiny-Input-Control/.DS_Store b/inst/App/projectTemplates/shiny-Input-Control/.DS_Store new file mode 100644 index 00000000..5456890f Binary files /dev/null and b/inst/App/projectTemplates/shiny-Input-Control/.DS_Store differ diff --git a/inst/App/projectTemplates/shiny-Input-Control/.workspace/PTR-TABID41cd6cdad2c7.rda b/inst/App/projectTemplates/shiny-Input-Control/.workspace/PTR-TABID41cd6cdad2c7.rda new file mode 100644 index 00000000..21e0724a Binary files /dev/null and b/inst/App/projectTemplates/shiny-Input-Control/.workspace/PTR-TABID41cd6cdad2c7.rda differ diff --git a/inst/App/projectTemplates/shiny-Input-Control/.workspace/PTR-TABID4e863aae5fe.rda b/inst/App/projectTemplates/shiny-Input-Control/.workspace/PTR-TABID4e863aae5fe.rda new file mode 100644 index 00000000..5290f451 Binary files /dev/null and b/inst/App/projectTemplates/shiny-Input-Control/.workspace/PTR-TABID4e863aae5fe.rda differ diff --git a/inst/App/projectTemplates/shiny-Input-Control/.workspace/PTR-TABID4e867f16b059.rda b/inst/App/projectTemplates/shiny-Input-Control/.workspace/PTR-TABID4e867f16b059.rda new file mode 100644 index 00000000..8c4aae6a Binary files /dev/null and b/inst/App/projectTemplates/shiny-Input-Control/.workspace/PTR-TABID4e867f16b059.rda differ diff --git a/inst/App/projectTemplates/shiny-Input-Control/.workspace/PTR-TABID5e821a75da45.rda b/inst/App/projectTemplates/shiny-Input-Control/.workspace/PTR-TABID5e821a75da45.rda new file mode 100644 index 00000000..2bba8fdf Binary files /dev/null and b/inst/App/projectTemplates/shiny-Input-Control/.workspace/PTR-TABID5e821a75da45.rda differ diff --git a/inst/App/projectTemplates/shiny-Input-Control/.workspace/PTR-TABID7274230e0fc4.rda b/inst/App/projectTemplates/shiny-Input-Control/.workspace/PTR-TABID7274230e0fc4.rda new file mode 100644 index 00000000..3e648dcc Binary files /dev/null and b/inst/App/projectTemplates/shiny-Input-Control/.workspace/PTR-TABID7274230e0fc4.rda differ diff --git a/inst/App/projectTemplates/shiny-Input-Control/.workspace/currentTab.rda b/inst/App/projectTemplates/shiny-Input-Control/.workspace/currentTab.rda new file mode 100644 index 00000000..3e4d8c14 Binary files /dev/null and b/inst/App/projectTemplates/shiny-Input-Control/.workspace/currentTab.rda differ diff --git a/inst/App/projectTemplates/shinyInput/.workspace/loadedDnippets.rda b/inst/App/projectTemplates/shiny-Input-Control/.workspace/loadedDnippets.rda similarity index 100% rename from inst/App/projectTemplates/shinyInput/.workspace/loadedDnippets.rda rename to inst/App/projectTemplates/shiny-Input-Control/.workspace/loadedDnippets.rda diff --git a/inst/App/projectTemplates/shiny-Input-Control/app.R b/inst/App/projectTemplates/shiny-Input-Control/app.R new file mode 100644 index 00000000..4dc12aa7 --- /dev/null +++ b/inst/App/projectTemplates/shiny-Input-Control/app.R @@ -0,0 +1,47 @@ +library(shiny) +source("shinyInputControl.R") + +initialValue='200' +inputId.1<-"shinyInputControlID-1" + +ui<-fluidPage( + h1('Test App'), + h3('current Value'), + textOutput('currentValue'), + + textInput(inputId='updateValue','update value', initialValue), + actionButton('updateButton', label='press to update value'), + + shinyInputControl(inputId=inputId.1, value= initialValue) +) + +server<-function(input,output,session){ + output$currentValue<-renderText(input[[ inputId.1 ]]) + + + observeEvent(input$updateButton,{ + value<-input$updateValue + tryCatch({ + + # STEP 3.1: + # 1. prepare value for update: + # for example: + # for non-text values consider using either + # i) value<-eval(parse(text=value)) + # or if value is numeric + # ii) value<-as.numeric(value) + # 2. call updateShinyInputControl + # for example: + # updateShinyInputControl(session, inputId=inputId.1, value=value ) + + }, + error=function(e){ + # do nothing , record error + print('error') + }) + }, + ignoreInit = TRUE + ) +} + +shinyApp(ui=ui, server=server) diff --git a/inst/App/projectTemplates/shiny-Input-Control/aux/.DS_Store b/inst/App/projectTemplates/shiny-Input-Control/aux/.DS_Store new file mode 100644 index 00000000..d87215db Binary files /dev/null and b/inst/App/projectTemplates/shiny-Input-Control/aux/.DS_Store differ diff --git a/inst/App/projectTemplates/shiny-Input-Control/aux/dnds/cntl.dnds b/inst/App/projectTemplates/shiny-Input-Control/aux/dnds/cntl.dnds new file mode 100644 index 00000000..2b0bd90a --- /dev/null +++ b/inst/App/projectTemplates/shiny-Input-Control/aux/dnds/cntl.dnds @@ -0,0 +1,174 @@ +--- +title: "Dnd Snippet" +author: "Anonymous" +date: "TODAY" +output: dnd_snippet +--- + +- Individual drippets are seperate by lines consisting of three or more stars (*) +- Each drippet consists of 3 entries, with each entry having a title and a value (block) + - The title consists of a single line followed by a colon (:) + - titles are *POPUP*, *SNIPPET*, *SVGR* + - The values are blocks defined by 3 backtics *````* +- Two drippets are shown below to help you get started + +****************** +POPUP +``` +toJSON (Steps 2,2.1 3.2.1?) +``` +SNIPPET +``` + toJSON('${1:value'}}); +``` +SVGR +``` +library(svgR) +WH<-c(48,32) +ptR<-list( + x=matrix(0,2,0) +) +R<-.06*WH[1] +d<-list(M=WH*c(.8,.85), Q=WH*c(c(.12,.85),c(.12,.52))) + +svgR(wh=WH, #stroke.width=1, stroke="#00FFFF", fill="none", + polygon(points=WH*c(c(.25,.5), c(.15,.3),c(.15,.7)),fill='#00FFFF'), + rect(cxy=WH*c(.1,.5), wh=WH*c(.1,.1),fill="#00FFFF"), + text(cxy=WH*c(.6,.5),'JSon', fill="#00FFFF", stroke="#00FFFF", + stroke.width=1) +) +``` + +********************* +********************* + + +POPUP +``` +Forward click cmd (Step 5.2) +``` +SNIPPET +``` +sprintf('@projectName@Binding.clicked("%s", "%s", evt)',params\$ID, mssg) +``` +SVGR +``` +library(svgR) +WH<-c(48,32) +ptR<-list( + x=matrix(0,2,0) +) +R<-WH[1]*.2 +CXY=WH*c(.3,.5) +svgR(wh=WH, stroke="#00FFFF", fill="none", + text(xy=c(.05,.3)*WH,'CMDS', font.size=9), + g( + polygon( + points=c(WH)*c( + c(.0,.0),c(.2,.5), c(.05,.3), c(.05,.6), + c(-.05,.6),c(-.05,.3), c(-.2,.5) + ), + stroke="#00FFFF" + ), + lapply(c(0,45,135), function(theta){ + line(xy1=c(.1,0)*WH, xy2=c(.3,0)*WH, stroke="#00FFFF", + transform=list(rotate=-theta) + ) + }), + transform=list( translate=WH*c(.6,.45), rotate=65) + ) +) +``` +********************* +****************** +POPUP +``` +fromJSON (Step 6.1?) +``` +SNIPPET +``` + fromJSON('${0:(value)}); +``` +SVGR +``` +library(svgR) +WH<-c(48,32) +ptR<-list( + x=matrix(0,2,0) +) +R<-.06*WH[1] +d<-list(M=WH*c(.8,.85), Q=WH*c(c(.12,.85),c(.12,.52))) + +svgR(wh=WH, #stroke.width=1, stroke="#00FFFF", fill="none", + polygon(points=WH*c(c(.05,.5), c(.15,.3),c(.15,.7)),fill='#00FFFF'), + rect(cxy=WH*c(.2,.5), wh=WH*c(.1,.1),fill="#00FFFF"), + text(cxy=WH*c(.6,.5),'JSon', fill="#00FFFF", stroke="#00FFFF", + stroke.width=1) +) +``` + +********************* + +POPUP +``` +Update (Step 3.2) +``` +SNIPPET +``` + #1. Recreate svg Tree + node<-as.character(@projectName@SvgWrapper( + params=list(ID=inputId, ${1:value}=value) # <<-- + )) + # 2. Form message + mssg<-list(node=node, value=value) + # 3. Send message to client + session\$sendInputMessage(inputId, mssg) + +``` +SVGR +``` +library(svgR) +WH<-c(48,32) +ptR<-list( + x=matrix(0,2,0) +) +X=c(.2,.4,.6,.8) + +svgR(wh=WH, stroke.width=3, stroke="#00FFFF", fill="#00FFFF", + # + line(xy1=WH*c(.1,.1), xy2=WH*c(.9,.1) ), + line(xy1=WH*c(.1,.23), xy2=WH*c(.9,.23) ), + line(xy1=WH*c(.5,.4), xy2=WH*c(.5,.9) ), + polygon(points=WH*c( .5,.3, .7,.5, .3,.5)) + +) +``` +****************** + +****************** +POPUP +``` +update svg (Step 7) +``` +SNIPPET +``` +update@ProjectName@(session=shinysession, inputId=inputId, value=value ) +``` +SVGR +``` +library(svgR) +WH<-c(48,32) +ptR<-list( + x=matrix(0,2,0) +) + + +svgR(wh=WH, stroke.width=3, stroke="#00FFFF", fill="#00FFFF", + line(xy1=WH*c(.1,.1), xy2=WH*c(.9,.1) ), + line(xy1=WH*c(.1,.23), xy2=WH*c(.9,.23) ), + polygon(points=WH*c( .5,.3, .7,.5, .3,.5)), + polyline(points=WH*c(.1, .5, .1,.85, .5,.85, .5,.4 ) , fill="none") +) +``` +********************* + diff --git a/inst/App/sampleProjects/shinyDialInput/aux/dnds/jstools.dnds b/inst/App/projectTemplates/shiny-Input-Control/aux/dnds/jstools.dnds similarity index 73% rename from inst/App/sampleProjects/shinyDialInput/aux/dnds/jstools.dnds rename to inst/App/projectTemplates/shiny-Input-Control/aux/dnds/jstools.dnds index baf3ee98..4521989e 100644 --- a/inst/App/sampleProjects/shinyDialInput/aux/dnds/jstools.dnds +++ b/inst/App/projectTemplates/shiny-Input-Control/aux/dnds/jstools.dnds @@ -4,24 +4,53 @@ author: "Anonymous" date: "TODAY" output: dnd_snippet --- +****************** +POPUP +``` +extract attribute (Steps 2.3.1) +``` +SNIPPET +``` + let value = $(el).attr('${0:value}'); +``` +SVGR +``` +library(svgR) +WH<-c(48,32) +ptR<-list( + x=matrix(0,2,0) +) +R<-.06*WH[1] +d<-list(M=WH*c(.65,.2), Q=WH*c(c(.25,.15),c(.25,.4))) +R<-.06*WH[1] +#d<-list(M=WH*c(.2,.42), Q=WH*c(c(.2,.8),c(.5,.8))) +svgR(wh=WH, #stroke.width=1, stroke="#00FFFF", fill="none", + #polygon(points=WH*c(c(.05,.5), c(.15,.3),c(.15,.7)),fill='#00FFFF'), + + #rect(cxy=WH*c(.2,.5), wh=WH*c(.1,.1),fill="#00FFFF"), + path(d=d, stroke="#00FFFF", stroke.width=2, + marker.end=marker(viewBox=c(0, 0, 10, 10), + refXY=c(1,5), stroke.width=1, fill="#00FFFF", + markerWidth=4, markerHeight=5, orient="auto", + path( d=c("M", 0, 0, "L", 9, 5, "L", 0, 9, "z") ) + ) ), + text(xy=WH*c(.05,.9),'attr', fill="#00FFFF"), + text(xy=WH*c(.7,.4),'el', fill="#00FFFF") +) +``` +****************** ********************* POPUP ``` -add mouse2pt function +From String (steps 3.2 3.3.2?) ``` SNIPPET ``` -mouse2pt: function(id, x, y){ //method to convert mouse coord to svg coord - var thisSVG=document.querySelector("#" + id +" svg"); - var pt= thisSVG.createSVGPoint(); - pt.x = x; - pt.y = y; - return pt.matrixTransform(thisSVG.getScreenCTM().inverse()); -} +JSON.parse(${1:'{x:1, y:1\}'}) ``` SVGR ``` @@ -30,36 +59,141 @@ WH<-c(48,32) ptR<-list( x=matrix(0,2,0) ) -R<-WH[1]*.2 -CXY=WH*c(.3,.5) - - +r=WH[2]/3 +lft=WH[1]/2-1.5*r +top<-WH[2]/2-r +bot<-WH[2]/2+r svgR(wh=WH, - circle(cxy=CXY+c(-R,-R), r=R/4, fill='#00FFFF'), - circle(cxy=CXY+c(-R,+R), r=R/4, fill='#00FFFF'), + polygon(points=WH*c(c(.05,.5), c(.15,.3),c(.15,.7)),fill='#00FFFF'), + rect(cxy=WH*c(.2,.5), wh=WH*c(.1,.1),fill="#00FFFF"), circle( - cxy=CXY, - r=R, + cxy=WH/2, + r=WH[2]/3, + stroke='none', fill='#00FFFF' ), - rect(xy=CXY-c(0,R), wh=c(.5,.6)*WH, fill='#00FFFF'), - line(xy1=CXY-c(0,R),xy2=CXY+c(0,R), stroke='black'), - line(xy1=CXY-c(R,0),xy2=CXY, stroke='black'), - #polygon(points=WH*c(c(.1,.5),c(.25,.2),c(.25,.8)), fill='#00FFFF'), - text(cxy=WH/2, "xy") + path( + d=list( + M=c(.4,.8)*WH, + C=c( c(.6,1.2),c(.9,.2), c(.8,.9))*WH + ), + stroke='#00FFFF', + stroke.width=1, + fill='none' + ), + g( + lapply(1:3, function(i){ + ellipse(cxy=WH*c(.5, .1), rxy=i*c(8,3), fill='none', stroke='#000000', stroke.width=.5) + }), + mask=mask(circle(cxy=WH/2, r=WH[2]/3), fill='white' ) + ), + g( + lapply(1:5, function(i){ + ellipse(cxy=WH*c(.7, .5), rxy=i*c(3,5), fill='none', stroke='#000000', stroke.width=.5) + }), + mask=mask( + circle(cxy=WH/2, r=WH[2]/3, fill='white'), + ellipse(cxy=WH*c(.5, .1), rxy=3*c(8,3), fill='black') + ) + ), + g( + lapply(1:5, function(i){ + ellipse(cxy=WH*c(.3, .3), rxy=i*c(3,5), fill='none', stroke='#000000', stroke.width=.5) + }), + mask=mask( + circle(cxy=WH/2, r=WH[2]/3, fill='white'), + ellipse(cxy=WH*c(.5, .1), rxy=3*c(8,3), fill='black'), + ellipse(cxy=WH*c(.7, .5), rxy=5*c(3,5), fill='black') + ) + ) ) ``` ********************* +****************** +POPUP +``` +set element data (Step 3.3.3) +``` +SNIPPET +``` + $(el).data('${1:value'}, ${0:value}); +``` +SVGR +``` +library(svgR) +WH<-c(48,32) +ptR<-list( + x=matrix(0,2,0) +) +R<-.06*WH[1] +d<-list(M=WH*c(.8,.85), Q=WH*c(c(.12,.85),c(.12,.52))) + +svgR(wh=WH, #stroke.width=1, stroke="#00FFFF", fill="none", + polygon(points=WH*c(c(.25,.5), c(.15,.3),c(.15,.7)),fill='#00FFFF'), + rect(cxy=WH*c(.1,.5), wh=WH*c(.1,.1),fill="#00FFFF"), + lapply(1:5, function(i){ + ellipse( + cxy=c(.6, .8-i*.1)*WH, + rxy=c(.2,.1)*WH, + stroke='black', + fill='#00FFFF', + stroke='black', + stroke.width=.5 + ) + }) +) +``` +****************** POPUP ``` -add mouse click +get element data ``` SNIPPET ``` -clicked: function(ctrlId, evt ){ - ${0:0} -} + $(el).data('${0:value}'); +``` +SVGR +``` +library(svgR) +WH<-c(48,32) +ptR<-list( + x=matrix(0,2,0) +) +R<-.06*WH[1] +d<-list(M=WH*c(.8,.42), Q=WH*c(c(.8,.8),c(.2,.8))) + +svgR(wh=WH, #stroke.width=1, stroke="#00FFFF", fill="none", + polygon(points=WH*c(c(.05,.5), c(.15,.3),c(.15,.7)),fill='#00FFFF'), + rect(cxy=WH*c(.2,.5), wh=WH*c(.1,.1),fill="#00FFFF"), + lapply(1:5, function(i){ + ellipse( + cxy=c(.6, .8-i*.1)*WH, + rxy=c(.2,.1)*WH, + stroke='black', + fill='#00FFFF', + stroke='black', + stroke.width=.5 + ) + }) +) +``` +****************** + + +********************* + +POPUP +``` +add mouse click handler (step 5.1) +``` +SNIPPET +``` +clicked: function(ctrlId, ${1:value,} evt ){ + alert('hi from '+ ctrlId +" my value is " + ${0:value}); //for testing + let el='#'+ctrlId; + // add code here +}, ``` SVGR ``` @@ -91,16 +225,25 @@ svgR(wh=WH, stroke="#00FFFF", fill="none", ) ``` + + ****************** +********************* + + POPUP ``` -replace node +add mouse2pt function ``` SNIPPET ``` - var htm=data.${1,value}; //value - var node=jQuery.parseHTML( htm ); - ${0,(el)}.empty().append(node); +mouse2pt: function(id, x, y){ //method to convert mouse coord to svg coord + let thisSVG=document.querySelector("#" + id +" svg"); + let pt= thisSVG.createSVGPoint(); + pt.x = x; + pt.y = y; + return pt.matrixTransform(thisSVG.getScreenCTM().inverse()); +} ``` SVGR ``` @@ -109,32 +252,33 @@ WH<-c(48,32) ptR<-list( x=matrix(0,2,0) ) -R<-.06*WH[1] -d<-list(M=WH*c(.2,.42), Q=WH*c(c(.2,.8),c(.5,.8))) +R<-WH[1]*.2 +CXY=WH*c(.3,.5) -svgR(wh=WH, stroke.width=2, stroke="#00FFFF", fill="none", - #circle(cxy=WH*c(.2,.2), fill="#00FFFF", r=R), - #circle(cxy=WH*c(.8,.2), fill="#00FFFF", r=R), - #rect(xy=WH*c(.16,.32), fill="#00FFFF", wh=c(.6,.16)*WH), - text(xy=WH*c(.16,.38),'html', stroke.width=1, fill="#00FFFF"), - circle(cxy=WH*(c(1,1)-c(.2,.2)), r=R), - path(d=d, stroke="#00FFFF", - marker.end=marker(viewBox=c(0, 0, 10, 10), refXY=c(1,5), stroke.width=1, fill="#00FFFF", - markerWidth=4, markerHeight=5, orient="auto", - path( d=c("M", 0, 0, "L", 9, 5, "L", 0, 9, "z") ) - ) - ) + +svgR(wh=WH, + circle(cxy=CXY+c(-R,-R), r=R/4, fill='#00FFFF'), + circle(cxy=CXY+c(-R,+R), r=R/4, fill='#00FFFF'), + circle( + cxy=CXY, + r=R, + fill='#00FFFF' + ), + rect(xy=CXY-c(0,R), wh=c(.5,.6)*WH, fill='#00FFFF'), + line(xy1=CXY-c(0,R),xy2=CXY+c(0,R), stroke='black'), + line(xy1=CXY-c(R,0),xy2=CXY, stroke='black'), + text(cxy=WH/2, "xy") ) ``` -****************** -****************** +********************* +******************** POPUP ``` -get attribute +Trigger ``` SNIPPET ``` - var attr = $(el).attr(`${1:data-Z}`); +${1:$(el)}.trigger(${0:"change"}); ``` SVGR ``` @@ -143,30 +287,28 @@ WH<-c(48,32) ptR<-list( x=matrix(0,2,0) ) -R<-.06*WH[1] -d<-list(M=WH*c(.2,.42), Q=WH*c(c(.2,.8),c(.5,.8))) +X=c(.2,.4,.6,.8) +D<-list( + M=c(.2,.2), + Q=c( ) +) +svgR(wh=WH, #stroke.width=1, stroke="#00FFFF", fill="none", + path(d=c("M",c(10,5), "Q", c(5,20), c(25,25) , "T", c(40,5)) , fill='#00FFFF'), + path(d=c("M",c(12,8), "Q", c(8,20), c(25,22) , "T", c(36,8)) , fill='black'), + path(d=c( "M", c(24,8), "C", c(22,10), c(30,10), c( 18,18), "Q" , c(30,15), c(28,10), c(32,10), c(32,8)),fill='#00FFFF') -svgR(wh=WH, stroke.width=2, stroke="#00FFFF", fill="none", - text(xy=WH*c(.2,.38),'attr', stroke.width=1, fill="#00FFFF"), - path(d=d, stroke="#00FFFF", - marker.end=marker(viewBox=c(0, 0, 10, 10), refXY=c(1,5), stroke.width=1, fill="#00FFFF", - markerWidth=4, markerHeight=5, orient="auto", - path( d=c("M", 0, 0, "L", 9, 5, "L", 0, 9, "z") ) - ) - ) + ) ``` ****************** -****************** + POPUP ``` -get element data +extract value from data (6.3.1) ``` SNIPPET ``` - var htm=data.${1,value}; //value - var node=jQuery.parseHTML( htm ); - ${0,(el)}.empty().append(node); +let value = data.value; ``` SVGR ``` @@ -175,36 +317,20 @@ WH<-c(48,32) ptR<-list( x=matrix(0,2,0) ) -R<-.06*WH[1] -d<-list(M=WH*c(.8,.42), Q=WH*c(c(.8,.8),c(.2,.8))) - -svgR(wh=WH, #stroke.width=1, stroke="#00FFFF", fill="none", - polygon(points=WH*c(c(.05,.5), c(.15,.3),c(.15,.7)),fill='#00FFFF'), - rect(cxy=WH*c(.2,.5), wh=WH*c(.1,.1),fill="#00FFFF"), - lapply(1:5, function(i){ - ellipse( - cxy=c(.6, .8-i*.1)*WH, - rxy=c(.2,.1)*WH, - stroke='black', - fill='#00FFFF', - stroke='black', - stroke.width=.5 - ) - }) +svgR(wh=WH, + text(cxy=WH/2, "Xval", stroke='#00FFFF', fill='#00FFFF') ) ``` -****************** +********************* +********************* -****************** POPUP ``` -set element data +set this value (6.3.3) ``` SNIPPET ``` - var htm=data.${1,value}; //value - var node=jQuery.parseHTML( htm ); - ${0,(el)}.empty().append(node); +this.setValue($(el), value); ``` SVGR ``` @@ -213,38 +339,21 @@ WH<-c(48,32) ptR<-list( x=matrix(0,2,0) ) -R<-.06*WH[1] -d<-list(M=WH*c(.8,.85), Q=WH*c(c(.12,.85),c(.12,.52))) - -svgR(wh=WH, #stroke.width=1, stroke="#00FFFF", fill="none", - polygon(points=WH*c(c(.25,.5), c(.15,.3),c(.15,.7)),fill='#00FFFF'), - rect(cxy=WH*c(.1,.5), wh=WH*c(.1,.1),fill="#00FFFF"), - lapply(1:5, function(i){ - ellipse( - cxy=c(.6, .8-i*.1)*WH, - rxy=c(.2,.1)*WH, - stroke='black', - fill='#00FFFF', - stroke='black', - stroke.width=.5 - ) - }) +svgR(wh=WH, + text(cxy=WH/2, "Sval", stroke='#00FFFF', fill='#00FFFF') ) ``` - ********************* - - ********************* - POPUP ``` -To string +replace svg tree (Step 6.4.3) ``` SNIPPET ``` -JSON.stringify(${1:obj}) +let node=data.${0:node}; //value +$(el).empty().append(node); ``` SVGR ``` @@ -253,65 +362,70 @@ WH<-c(48,32) ptR<-list( x=matrix(0,2,0) ) -r=WH[2]/3 -lft=WH[1]/2-1.5*r -top<-WH[2]/2-r -bot<-WH[2]/2+r -svgR(wh=WH, - polygon(points=WH*c(c(.25,.5), c(.15,.3),c(.15,.7)),fill='#00FFFF'), - rect(cxy=WH*c(.1,.5), wh=WH*c(.1,.1),fill="#00FFFF"), - circle( - cxy=WH/2, - r=WH[2]/3, - stroke='none', - fill='#00FFFF' - ), - path( - d=list( - M=c(.4,.8)*WH, - C=c( c(.6,1.2),c(.9,.2), c(.8,.9))*WH - ), - stroke='#00FFFF', - stroke.width=1, - fill='none' - ), - g( - lapply(1:3, function(i){ - ellipse(cxy=WH*c(.5, .1), rxy=i*c(8,3), fill='none', stroke='#000000', stroke.width=.5) - }), - mask=mask(circle(cxy=WH/2, r=WH[2]/3), fill='white' ) - ), - g( - lapply(1:5, function(i){ - ellipse(cxy=WH*c(.7, .5), rxy=i*c(3,5), fill='none', stroke='#000000', stroke.width=.5) - }), - mask=mask( - circle(cxy=WH/2, r=WH[2]/3, fill='white'), - ellipse(cxy=WH*c(.5, .1), rxy=3*c(8,3), fill='black') +R<-.06*WH[1] +d<-list(M=WH*c(.2,.42), Q=WH*c(c(.2,.8),c(.5,.8))) + +svgR(wh=WH, stroke.width=2, stroke="#00FFFF", fill="none", + text(xy=WH*c(.16,.38),'svg', stroke.width=1, fill="#00FFFF"), + ellipse(cxy=WH*(c(1,1)-c(.2,.55)), rxy=R*c(2,1), fill="#00FFFF"), + line(xy1=WH*(c(1,1)-c(.2,.1)), xy2=WH*(c(1,1)-c(.2,.3)) ), + line(xy1=WH*(c(1,1)-c(.2,.3)), xy2=WH*(c(1,1)-c(.25,.5)),stroke.width=1.5 ), + line(xy1=WH*(c(1,1)-c(.2,.3)), xy2=WH*(c(1,1)-c(.15,.5)),stroke.width=1.9 ), + path(d=d, stroke="#00FFFF", + marker.end=marker(viewBox=c(0, 0, 10, 10), refXY=c(1,5), stroke.width=1, fill="#00FFFF", + markerWidth=4, markerHeight=5, orient="auto", + path( d=c("M", 0, 0, "L", 9, 5, "L", 0, 9, "z") ) + ) ) - ), - g( - lapply(1:5, function(i){ - ellipse(cxy=WH*c(.3, .3), rxy=i*c(3,5), fill='none', stroke='#000000', stroke.width=.5) - }), - mask=mask( - circle(cxy=WH/2, r=WH[2]/3, fill='white'), - ellipse(cxy=WH*c(.5, .1), rxy=3*c(8,3), fill='black'), - ellipse(cxy=WH*c(.7, .5), rxy=5*c(3,5), fill='black') +) +``` +****************** +****************** +POPUP +``` +set svg node attribute +``` +SNIPPET +``` +let node=document.getElementById( ${1:nodeId}); +node.setAttribute('${2:attrName}', ${0:attrValue}); +``` +SVGR +``` +library(svgR) +WH<-c(48,32) +ptR<-list( + x=matrix(0,2,0) +) +R<-.06*WH[1] +d<-list(M=WH*c(.2,.42), Q=WH*c(c(.2,.8),c(.5,.8))) + +svgR(wh=WH, stroke.width=2, stroke="#00FFFF", fill="none", + text(xy=WH*c(.05,.38),'attr', stroke.width=1, fill="#00FFFF"), + text(xy=WH*c(.6,.9),'n', stroke.width=.5, fill="#00FFFF"), + path(d=d, stroke="#00FFFF", + marker.end=marker(viewBox=c(0, 0, 10, 10), refXY=c(1,5), stroke.width=1, fill="#00FFFF", + markerWidth=4, markerHeight=5, orient="auto", + path( d=c("M", 0, 0, "L", 9, 5, "L", 0, 9, "z") ) + ) ) - ) ) ``` +****************** + +********************* + + ********************* POPUP ``` -From string +To string ``` SNIPPET ``` -JSON.parse(${1:obj}) +JSON.stringify(${1:{x:1, y:1}}) ``` SVGR ``` @@ -325,8 +439,8 @@ lft=WH[1]/2-1.5*r top<-WH[2]/2-r bot<-WH[2]/2+r svgR(wh=WH, - polygon(points=WH*c(c(.05,.5), c(.15,.3),c(.15,.7)),fill='#00FFFF'), - rect(cxy=WH*c(.2,.5), wh=WH*c(.1,.1),fill="#00FFFF"), + polygon(points=WH*c(c(.25,.5), c(.15,.3),c(.15,.7)),fill='#00FFFF'), + rect(cxy=WH*c(.1,.5), wh=WH*c(.1,.1),fill="#00FFFF"), circle( cxy=WH/2, r=WH[2]/3, @@ -369,6 +483,7 @@ svgR(wh=WH, ) ) ``` +********************* ********************* @@ -379,7 +494,7 @@ LOG ``` SNIPPET ``` -console.log(${1:'text '+} ${0:value}); +console.log(${1:'value='+} ${0:value}) ``` SVGR ``` @@ -415,36 +530,3 @@ svgR(wh=WH, ``` ********************* -POPUP -``` -Trigger -``` -SNIPPET -``` -${1:$(el)}.trigger(${0:"change"}); -``` -SVGR -``` -library(svgR) -WH<-c(48,32) -ptR<-list( - x=matrix(0,2,0) -) -X=c(.2,.4,.6,.8) -D<-list( - M=c(.2,.2), - Q=c( ) -) -svgR(wh=WH, #stroke.width=1, stroke="#00FFFF", fill="none", - path(d=c("M",c(10,5), "Q", c(5,20), c(25,25) , "T", c(40,5)) , fill='#00FFFF'), - path(d=c("M",c(12,8), "Q", c(8,20), c(25,22) , "T", c(36,8)) , fill='black'), - path(d=c( "M", c(24,8), "C", c(22,10), c(30,10), c( 18,18), "Q" , c(30,15), c(28,10), c(32,10), c(32,8)),fill='#00FFFF') - - -) -``` -****************** - - - - diff --git a/inst/App/projectTemplates/shiny-Input-Control/aux/dnds/mouseEvents.dnds b/inst/App/projectTemplates/shiny-Input-Control/aux/dnds/mouseEvents.dnds new file mode 100644 index 00000000..4e44329f --- /dev/null +++ b/inst/App/projectTemplates/shiny-Input-Control/aux/dnds/mouseEvents.dnds @@ -0,0 +1,228 @@ +--- +title: "Dnd Snippet" +author: "Anonymous" +date: "TODAY" +output: dnd_snippet +--- + +********************* + +POPUP +``` +mouse click +``` +SNIPPET +``` +onclick=CMDS[${0:1}] +``` +SVGR +``` +library(svgR) +WH<-c(48,32) +ptR<-list( + x=matrix(0,2,0) +) +R<-WH[1]*.2 +CXY=WH*c(.3,.5) +svgR(wh=WH, stroke="#00FFFF", fill="none", + g( + polygon( + points=c(WH)*c( + c(.0,.0),c(.2,.5), c(.05,.3), c(.05,.6), + c(-.05,.6),c(-.05,.3), c(-.2,.5) + ), + stroke="#00FFFF" + ), + lapply(c(0,45,135,180), function(theta){ + line(xy1=c(.1,0)*WH, xy2=c(.3,0)*WH, stroke="#00FFFF", + transform=list(rotate=-theta) + ) + }), + transform=list( translate=WH*c(.6,.45), rotate=65) + ) +) +``` + +****************** +********************* + + +POPUP +``` +mouse down +``` +SNIPPET +``` +onmousedown=CMDS[${0:1}] +``` +SVGR +``` +library(svgR) +WH<-c(48,32) +ptR<-list( + x=matrix(0,2,0) +) +R<-WH[2]*.2 +CXY=WH*c(.5,.7) + + +svgR(wh=WH, + circle( + cxy=CXY, + r=R, + fill='#00FFFF' + ), + rect(xy=CXY-c(R,2*R), wh=c(2*R,2*R), fill='#00FFFF'), + line(xy1=CXY-c(R,0),xy2=CXY+c(R,0), stroke='black'), + line(xy1=CXY+c(0,R),xy2=CXY, stroke='black') + +) +``` +********************* + + +********************* + + +POPUP +``` +mouse up +``` +SNIPPET +``` +onmouseup=CMDS[${0:1}] +``` +SVGR +``` +library(svgR) +WH<-c(48,32) +ptR<-list( + x=matrix(0,2,0) +) +R<-WH[2]*.2 +CXY=WH*c(.5,.3) + + +svgR(wh=WH, + circle( + cxy=CXY, + r=R, + fill='#00FFFF' + ), + rect(xy=CXY-c(R,0), wh=c(2*R,2*R), fill='#00FFFF'), + line(xy1=CXY-c(R,0),xy2=CXY+c(R,0), stroke='black'), + line(xy1=CXY-c(0,R),xy2=CXY, stroke='black') + +) +``` +********************* + +********************* + + +POPUP +``` +mouse over +``` +SNIPPET +``` +onmouseover=CMDS[${0:1}] +``` +SVGR +``` +library(svgR) +WH<-c(48,32) +ptR<-list( + x=matrix(0,2,0) +) +R<-WH[2]*.2 +CXY=WH*c(.6,.4) + + +svgR(wh=WH, + rect(xy=WH*c(.2,.1), wh=c(.6,.8)*WH, stroke='#00FFFF', fill='none'), + circle( + cxy=CXY, + r=R, + fill='#00FFFF' + ), + rect(xy=CXY-c(2*R,R), wh=c(2*R,2*R), fill='#00FFFF'), + line(xy1=CXY-c(0,R),xy2=CXY+c(0,R), stroke='black'), + line(xy1=CXY+c(R,0),xy2=CXY, stroke='black') + +) +``` +********************* + +********************* + +POPUP +``` +mouse move +``` +SNIPPET +``` +onmousemove=CMDS[${0:1}] +``` +SVGR +``` +library(svgR) +WH<-c(48,32) +ptR<-list( + x=matrix(0,2,0) +) +R<-WH[2]*.2 +CXY=WH*c(.6,.5) + + +svgR(wh=WH, + circle( + cxy=CXY, + r=R, + fill='#00FFFF' + ), + rect(xy=CXY-c(2*R,R), wh=c(2*R,2*R), fill='#00FFFF'), + line(xy1=CXY-c(0,R),xy2=CXY+c(0,R), stroke='black'), + line(xy1=CXY+c(R,0),xy2=CXY, stroke='black'), + line(xy1=CXY+c(-4*R,-R),xy2=CXY+c(-4*R,R), stroke='#00FFFF'), + line(xy1=CXY+c(-3*R,-R),xy2=CXY+c(-3*R,R), stroke='#00FFFF'), + line(xy1=CXY+c(-2.5*R,-R),xy2=CXY+c(-2.5*R,R), stroke='#00FFFF') +) +``` +****************** +********************* + +POPUP +``` +mouse out +``` +SNIPPET +``` +onmouseout=CMDS[${0:1}] +``` +SVGR +``` +library(svgR) +WH<-c(48,32) +ptR<-list( + x=matrix(0,2,0) +) +R<-WH[2]*.2 +CXY=WH*c(.5,.5) + + +svgR(wh=WH, + circle( + cxy=CXY, + r=R, + fill='none' + , stroke='#00FFFF' + ), + rect(xy=CXY-c(2*R,R), wh=c(2*R,2*R), fill='black', stroke='#00FFFF'), + line(xy1=CXY-c(0,R),xy2=CXY+c(0,R), stroke='#00FFFF'), + line(xy1=CXY+c(R,0),xy2=CXY, stroke='#00FFFF') + +) +``` +****************** + diff --git a/inst/App/projectTemplates/reactiveChartBldr/aux/dnds/sampleShapes.dnds b/inst/App/projectTemplates/shiny-Input-Control/aux/dnds/sampleShapes.dnds similarity index 97% rename from inst/App/projectTemplates/reactiveChartBldr/aux/dnds/sampleShapes.dnds rename to inst/App/projectTemplates/shiny-Input-Control/aux/dnds/sampleShapes.dnds index c85c7c3e..9cfe969e 100644 --- a/inst/App/projectTemplates/reactiveChartBldr/aux/dnds/sampleShapes.dnds +++ b/inst/App/projectTemplates/shiny-Input-Control/aux/dnds/sampleShapes.dnds @@ -23,7 +23,7 @@ SNIPPET ``` circle( cxy=${1:WH/2}, - r=${2:WH[2]/3}, + r=${2:min(WH)/3}, stroke='black', fill=${3:'none'} )${0:} @@ -197,8 +197,8 @@ SNIPPET polyline( points=${1:WH*matrix(c(.25,.25,.5,.5,.75,.25),2)}, stroke=${2:'black'}, - stroke.width=${2:1}, - fill=${3:'none'} + stroke.width=${3:1}, + fill=${4:'none'} )${0:} ``` SVGR @@ -228,8 +228,8 @@ SNIPPET polygon( points=${1:WH*matrix(c(.25,.75,.5,.5,.75,.75),2)}, stroke=${2:'black'}, - stroke.width=${2:1}, - fill=${3:'none'} + stroke.width=${3:1}, + fill=${4:'none'} )${0:} ``` SVGR @@ -329,7 +329,7 @@ SNIPPET path( d=list( M=${1:c(.5,.2)*WH}, - A=${2:c(2.3*WH, 180,1,0,c(.8,.5)*WH)} + A=${2:c(.3*WH, 180,1,0,c(.8,.5)*WH)} ), stroke=${3:'#0000FF'}, stroke.width=${4:2}, @@ -372,7 +372,7 @@ path( ${1:M=c(.2,.2)*WH,} Q=${2:c( c(.5,1.5),c(.8,.2))*WH} ), - stroke=${3:'#000FF'}, + stroke=${3:'#0000FF'}, stroke.width=${4:1}, fill=${5:'none'} )${0:} diff --git a/inst/App/projectTemplates/shiny-Input-Control/notes.Rmd b/inst/App/projectTemplates/shiny-Input-Control/notes.Rmd new file mode 100644 index 00000000..56322a87 --- /dev/null +++ b/inst/App/projectTemplates/shiny-Input-Control/notes.Rmd @@ -0,0 +1,136 @@ +--- +title: 'Notes on building shiny input controls' +author: 'author' +date: "2020-02-11" +output: html_document +--- + + +```{r setup, include=FALSE} +knitr::opts_chunk$set(echo = TRUE) +library(svgR) +``` + + + +# Details about the Strategies + + +## Notes on SVG +For initial SVG development it is convenient to keep the svgR in a seperate file +Thus we +- put svgR code in a seperate file: *shinyInputControl_svg.R* +- create a wrapper to source the svg +- call that wrapper from the constructor for *shinyInputControl* + +## Notes on Updating + +### What is updating + +Updating is the act of sending a message from the server to the client. +The message contains info to recreate appearence and value + +### What is the purpose of updating? + +The purpose of updating is to perform 2 objectives: + +- set a new value for the control +- change the control's appearence + + +### What are the steps of updating? + +- Starts in the server by calling the function *updateShinyInputControl* +- A message is formed to be sent to the client +- To send the message a call is made via *session\$sendInputMessage* +- The client receives the message in the function *receiveMessage* +- In *receiveMessage* + - extract the value + - reset the value via set value + - reset the appearence (via node manipulations) + +### Three Strategies to Update + +I. **Braindead**: (minimal js) + + 1. Recreate the svgTree with using new params + 2. Form message = value + svg + 3. send to the client + 4. client replaces tree and updates value + +II. **Mixedup**: + + 1. Recreate the svg with using new params + 2. get id of svg node that is affected + 3. Extract affected node from svg to send + 4. Form message = value + replacement-node + id of node + 5. send to the client + 6. find node given id and replace with replacement-node + +III. **Traditional**: (uses more js) + + 1. Form message = value + 2. Send to client + 3. Use javascript to update appearence base on value. + +We recommend the *Kindergarden* strategy to begin with. + + +## Notes on registerInputHandler + +### On the client side + +- svg sends a message to the **shinyInputControl**, probably **clicked** +- **clicked** resets the value via **setValue** +- The **setValue** function triggers a change message +- Inside the subscribe function a callback has been registered +to send a message containg the value to the server + +### On the server side + +#### Inputhandler +- The message from the client is received by the **inputhandler** + - The **inputhandler** was defined when we called **registerInputHandler** +- The **inputhandler** allows for preprocessing of the data before attaching it to the **input\$controlId** + - This preprocessing is need for lists, etc. + - The **inputhandler** returns a value to be assigned to **input\$controlId** + +#### How is the appearnce of the control changed? + +The appearance of the control can be changed in one of two ways: + +##### On the client side + +Prior to sending the value to the server via setValue use javascript to modify the appearance. +For example, one might do this inside the **:clicked** function. + +##### On the server side + +Inside the inputhandler function, after receiving the value, call an update with the +new value to force the client to redraw the control with that new value. + + +# Some supported events by SVG + +- SVG Mouse events + - onclick + - onmousedown + - onmouseup + - onmouseover + - onmousemove + - onmouseout +- SVG UIEvents + - onfocusin + - onfocusout + - onactivate +- SVG Misc + - onload + - onunload + - onabort + - onerror + - onresize + - onscroll + - onzoom + - onbegin + - onend + - onrepeat diff --git a/inst/App/sampleProjects/diagramMaker/ideas.html b/inst/App/projectTemplates/shiny-Input-Control/notes.html similarity index 97% rename from inst/App/sampleProjects/diagramMaker/ideas.html rename to inst/App/projectTemplates/shiny-Input-Control/notes.html index 031d9c49..e34d582b 100644 --- a/inst/App/sampleProjects/diagramMaker/ideas.html +++ b/inst/App/projectTemplates/shiny-Input-Control/notes.html @@ -11,9 +11,9 @@ - + -svgR in a Markdown Doc +Notes on building shiny input controls + + + + + + + + + + + + + + + + + + + + + + + + + + +
    + + + + + + + + + + + + + + + + +
    +

    Steps to Implement shinyInputControl

    +
    +

    1. Building your svg

    + +STEP1 shinyInputControl_svg.R add to params and svgR app.R commit to test + +
      +
    1. In file shinyInputControl_svg.R +
        +
      • Parameters section +
          +
        • contains variables: +
            +
          • WH (width height)
            • +
          • ID for the contol id
            • +
          • CMDS (may supply more than one)
            • +
          • +
        • Add here anything you want to be adjustable
          • +
        • +
      • add to the svgR(){} what you want to see
        • +
      2. +
    2. commit to test image
      3. +
    +
    +
    +

    2. Adding mouse events

    + +STEP2 shinyInputControl_svg.R add mouse events app.R run to test + +
      +
    • In file shinyInputControl_svg.R +
        +
      • add onclick=CMDS for interactivity
        • +
      • +
    • run App.R and test for on an click message
      • +
    • use browser to verify value was assigned
      • +
    +
    +
    +

    3. Initializing the Control

    + +STEP3 shinyInputControl.R edit shinyInputControl() shinyInputControl.js edit shinyInputControl() app.R run to test + +
      +
    1. In file shinyInputControl.R +
        +
      • in function shinyInputControl() +
          +
        • if necessary +
            +
          • preprocess the value argument
            • +
          • edit params
            • +
          • edit ‘data-value’=value
            • +
          • +
        • +
      2. +
    2. In file shinyInputControl.js +
        +
      • in function initialize +
          +
        • do any needed processing of data here +
            +
          • if a data value is a string representing an object +
              +
            • get value from data-value using ‘get element data’ dnd
              • +
            • convert into object using ‘From String’ dnd
              • +
            • set data-value using ‘set element data’ dnd
              • +
            • +
          • +
        • +
      3. +
    3. run App.R and use browser to verify data-value attached +
        +
      • in the browser panel (right hand side) +
          +
        • locate the div with the id matching your control id
          • +
        • verify that the data-value attribute appears and has the value you assigned
          • +
        • +
      4. +
    +
    +
    +

    4. Adding Mouseclick Handler

    + + STEP4 shinyInputControl.js add clicked: shinyInputControl.R edit params$CMDS app.R run to test + +
      +
    1. In shinyInputControl.js +
        +
      • add handler clicked: (assuming that you are using mouse click) +
          +
        • typically this will +
            +
          • getValue
            • +
          • do something
            • +
          • setValue
            • +
          • +
        • +
      2. +
    2. In shinyInputControl.R +
        +
      • edit params$CMDS to use cmd in client. (clicked) +
          +
        • sprintf(‘shinyInputControlBinding.clicked(“%s”, evt)’,params$ID)
          • +
        • +
      3. +
    3. run App.R and use browser to verify data-value is modified on click
      4. +
    +
    +
    +

    5. Handling Return Values From Client

    + + STEP5 shinyInputControl.R registerInputHandler app.R run to test + +
      +
    1. In file shinyInputControl.R +
        +
      • in registerInputHandler +
          +
        • do any post processing of value and return value
          • +
        • +
      2. +
    2. test return value of input$controlId in App.R
      3. +
    +
    +
    +

    6. Implement Updating using a Braindead Approach

    + +STEP6 app.R edit observer for update shinyInputControl.R recreate svgTree create message send message shinyInputControl.js extract value from data set element withvalue extract and replace tree app.R run to test + +
      +
    1. In App.R +
        +
      • Edit observeEvent(input$updateButton to call
        • +
      • updateshinyInputControl with the proper value
        • +
      2. +
    2. In file shinyInputControl.R (use dnd) +
        +
      1. Recreate svg Tree, edit params=list as necessary +
          +
        • params=list(ID=inputId, WH=wh, value=value)
          • +
        • svgTree<-shinyInputControlWrapper(params=params)
          • +
        • node<-as.character(svgTree)
          • +
        2. +
      2. Form message mssg<-list( value=value, node=node)
        3. +
      3. Send message to client +
          +
        • session$sendInputMessage(inputId, mssg)
          • +
        4. +
      3. +
    3. In file shinyInputControl.js in function receivemessage +
        +
      1. extract value(s) +
          +
        • var value = data.value;
          • +
        2. +
      2. Possibly convert to object: i.e. value=JSON.parse(value);
        3. +
      3. set element with new data +
          +
        • this.setValue($(el), value);
          • +
        4. +
      4. update svg rendering by replacing the entire svgTree under the $(el) +
          +
        • var node=data.node;
          • +
        • $(el).empty().append(node); //this replaces the svgTree
          • +
        5. +
      4. +
    4. In App.R validate that updateshinyInputControl works: - the appearance changes - value changes
      5. +
    +
    +
    +

    7. Updating the Appearance Upon Receiving Input

    + +STEP7 shinyInputControl.R add to registerInputHandler updateShinyInputControl(…) app.R run to test + +
      +
    • In shinyInputControl.R +
        +
      • In registerInputHandler prior to returning value +
          +
        • add updateshinyInputControl(…)
          • +
        • +
      • +
    +
    +
    + + + + +
    + + + + + + + + diff --git a/inst/App/projectTemplates/shiny-Input-Control/shinyInputControl.R b/inst/App/projectTemplates/shiny-Input-Control/shinyInputControl.R new file mode 100644 index 00000000..7fe8f34b --- /dev/null +++ b/inst/App/projectTemplates/shiny-Input-Control/shinyInputControl.R @@ -0,0 +1,85 @@ +library(shiny) +library(svgR) +# library(jsonlite) + +try({ removeInputHandler("shinyInputControlBinding") }) + +# add any helper functions here + +shinyInputControl.WH<-c(300,300) + +# create simple wrapper around svgR code +shinyInputControlSvgWrapper<-function(params){ + params$wh<-shinyInputControl.WH + # STEP 5.2: replace params$CMDS as appropriate + params$CMDS<-c( + "alert('Wrapper: new command(s)')" #replace this + ) + + # fill the wrapper + source('shinyInputControl_svg.R', local=T)$value +} + + +#' Constructor for the shinyInputControl +#' +#' @param inputId the id of this shiny input +#' @param value the initial value for this control +#' export +shinyInputControl<-function(inputId, value='whatever' ){ +# note: use toJSON for non-trivial initializations + # STEP 2.1 Place any preprocessing of (initial input) value(s) here + + # STEP 2.2 adjust params list as desired + params<-list(ID=inputId, value=value) + + tagList( + singleton(tags$head(tags$script(src = "shinyInputControl.js"))), + div( id=inputId, + class="shinyInputControl", + HTML(as.character( + shinyInputControlSvgWrapper(params) + )), + # STEP 2.3 customize for initialization by attaching data-*** to this div + # Note: + # 'data-xxx'=yyy only accepts vectors of length 1 + # for more complex data, try using toJSON to convert value + 'data-value'=value #attaches value as string to this div + ) + ) +} + +#' updateShinyInputControl +#' server to client update +#' +#' @param session the shiny session +#' @param inputId the control Id +#' @param value update with this value +#' @export +updateShinyInputControl<-function(session, inputId, value='bogus'){ + # Perform any value preprocessing here (toJSON if needed) + # STEP 3.2 Using Braindead Update Approach: + # STEP 3.2.1. Recreate svg Tree + # STEP 3.2.2. Form message + # STEP 3.2.3. Send message to client +} + + +# preprocess data returned to server from the client +shiny::registerInputHandler( + "shinyInputControlBinding", + function(value, shinysession, inputId) { + if(is.null(value) ) { + return("NULL") + } else { + # STEP 6.1: process value (may use fromJSON) + + # STEP 7: add updateShinyInputControl() + + return(value) + } + } +) + + + diff --git a/inst/App/projectTemplates/shinyInput/shinyInput.pprj b/inst/App/projectTemplates/shiny-Input-Control/shinyInputControl.pprj similarity index 81% rename from inst/App/projectTemplates/shinyInput/shinyInput.pprj rename to inst/App/projectTemplates/shiny-Input-Control/shinyInputControl.pprj index ccd1344d..c434297e 100644 --- a/inst/App/projectTemplates/shinyInput/shinyInput.pprj +++ b/inst/App/projectTemplates/shiny-Input-Control/shinyInputControl.pprj @@ -1,9 +1,9 @@ { "pathToProj": [ - "/home/sup/AA/shinyInput" + "~/BB/shinyInputControl" ], "projName": [ - "shinyInput.pprj" + "shinyInputControl.pprj" ], "projType": [ [ diff --git a/inst/App/projectTemplates/shiny-Input-Control/shinyInputControl_svg.R b/inst/App/projectTemplates/shiny-Input-Control/shinyInputControl_svg.R new file mode 100644 index 00000000..37f1d9fc --- /dev/null +++ b/inst/App/projectTemplates/shiny-Input-Control/shinyInputControl_svg.R @@ -0,0 +1,33 @@ +library(svgR) +library(tidyverse) + +#-------- params ---------------------- +#` default params +WH<-c(400,400) +CMDS<-"alert('control triggered')" +ID<-'mycontrol' + +# STEP 1.1: if needed, add to params, for example +# value=200 + +#----------function override of params---------- +if(exists("params") ){ + for(n in names(params)){ + assign(n, params[[n]]) + } +} + +#-----any R helper code goes here-------------------------- + +svgR(wh=WH, + #your custom code goes here + NULL + #STEP 1.2: add to svgR to create image + #STEP 4: mouse events (such as onclick=CMDS) +) + + + + + + diff --git a/inst/App/projectTemplates/shiny-Input-Control/www/shinyInputControl.js b/inst/App/projectTemplates/shiny-Input-Control/www/shinyInputControl.js new file mode 100644 index 00000000..1554870b --- /dev/null +++ b/inst/App/projectTemplates/shiny-Input-Control/www/shinyInputControl.js @@ -0,0 +1,59 @@ +// JAVASCRIPT + +//INPUT BINDING +var shinyInputControlBinding = new Shiny.InputBinding(); +$.extend(shinyInputControlBinding, { + find: function(scope) { + return $(scope).find(".shinyInputControl"); + }, + initialize: function(el){ + // STEP 2.3 Initialize element data here: + // may use the dnds: + // 1. get element data, hint: use dnd 'from string ' + }, + getValue: function(el) { + // Used for returning the value(s) of this input control + // Typically, held as element data, ie. $(el).data('value') + var value = $(el).data('value'); + // if value is an object, may want to use JSON.stringify + return value ; + }, + setValue: function(el, value) { + // used for updating input control + // Typically + // 1. set element data value + $(el).data('value', value); + // 2. then trigger element change + $(el).trigger("change"); + }, + subscribe: function(el, callback) { + // notify server whenever change + $(el).on("change.shinyInputControlBinding", function(e) { + callback(); + }); + }, + unsubscribe: function(el) { + $(el).off(".shinyInputControlBinding"); + }, + receiveMessage: function(el, data) { //called when server sends update message + if(!!data.value){ + // handle update here + // Step 3.3 + // Typically: + // 3.3.1. extract value(s) from data: Xval dnd + // 3.3.2. Possibly convert to object: may use 'fromString' dnd + // 3.3.3. set element with new data: may use Sval dnd + // 3.3.4. update svg rendering (if necessary :) (hint: svg-tree dnd) + } + }, + + // STEP 5.1 add handler clicked: (hint use) + + getType: function(el){ + return "shinyInputControlBinding"; + } +}); + +// REGISTER INPUT BINDING +Shiny.inputBindings.register(shinyInputControlBinding); + diff --git a/inst/App/projectTemplates/shinyInput/.workspace/PTR-TABID1b8a789c513.rda b/inst/App/projectTemplates/shinyInput/.workspace/PTR-TABID1b8a789c513.rda deleted file mode 100644 index a1171351..00000000 Binary files a/inst/App/projectTemplates/shinyInput/.workspace/PTR-TABID1b8a789c513.rda and /dev/null differ diff --git a/inst/App/projectTemplates/shinyInput/.workspace/PTR-TABID41cd6cdad2c7.rda b/inst/App/projectTemplates/shinyInput/.workspace/PTR-TABID41cd6cdad2c7.rda deleted file mode 100644 index 4556a66c..00000000 Binary files a/inst/App/projectTemplates/shinyInput/.workspace/PTR-TABID41cd6cdad2c7.rda and /dev/null differ diff --git a/inst/App/projectTemplates/shinyInput/.workspace/PTR-TABID704c2e20c007.rda b/inst/App/projectTemplates/shinyInput/.workspace/PTR-TABID704c2e20c007.rda deleted file mode 100644 index b240f0e5..00000000 Binary files a/inst/App/projectTemplates/shinyInput/.workspace/PTR-TABID704c2e20c007.rda and /dev/null differ diff --git a/inst/App/projectTemplates/shinyInput/.workspace/PTR-TABIDa9527235bba.rda b/inst/App/projectTemplates/shinyInput/.workspace/PTR-TABIDa9527235bba.rda deleted file mode 100644 index a661cf38..00000000 Binary files a/inst/App/projectTemplates/shinyInput/.workspace/PTR-TABIDa9527235bba.rda and /dev/null differ diff --git a/inst/App/projectTemplates/shinyInput/.workspace/currentTab.rda b/inst/App/projectTemplates/shinyInput/.workspace/currentTab.rda deleted file mode 100644 index 9b69586b..00000000 Binary files a/inst/App/projectTemplates/shinyInput/.workspace/currentTab.rda and /dev/null differ diff --git a/inst/App/projectTemplates/shinyInput/app.R b/inst/App/projectTemplates/shinyInput/app.R deleted file mode 100644 index 79fe9595..00000000 --- a/inst/App/projectTemplates/shinyInput/app.R +++ /dev/null @@ -1,39 +0,0 @@ -library(shiny) -source("shinyInputCntrl.R") - -ui<-fluidPage( - shinyInputCntrl(inputId='myshinyInput', wh=c(400,200), Z=c(2-2i, 2+2i) ), - h3('current Value'), - textOutput('currentValue'), - textInput(inputId='updateValue','update value', ''), - actionButton('updateButton', label='press to update value') -) - -server<-function(input,output,session){ - output$currentValue<-renderText( - paste('c(', paste(as.character(round(input$myshinyInput, digits=2)), collapse=", "), ')') - ) - - observeEvent(input$updateButton,{ - value<-input$updateValue - print('update button pressed') - tryCatch({ - - value<-eval(parse(text=value)) - - if(length(value)!=2 || class(value)!='complex'){ - stop('invalid input') - } - - updateShinyInputCntrl(session, 'myshinyInput', wh=c(400,200), Z=value) - }, - error=function(e){ - # do nothing , record error - print('error') - }) - } - - ) -} - -shinyApp(ui=ui, server=server) diff --git a/inst/App/projectTemplates/shinyInput/aux/dnds/jstools.dnds b/inst/App/projectTemplates/shinyInput/aux/dnds/jstools.dnds deleted file mode 100644 index baf3ee98..00000000 --- a/inst/App/projectTemplates/shinyInput/aux/dnds/jstools.dnds +++ /dev/null @@ -1,450 +0,0 @@ ---- -title: "Dnd Snippet" -author: "Anonymous" -date: "TODAY" -output: dnd_snippet ---- - - -********************* - - -POPUP -``` -add mouse2pt function -``` -SNIPPET -``` -mouse2pt: function(id, x, y){ //method to convert mouse coord to svg coord - var thisSVG=document.querySelector("#" + id +" svg"); - var pt= thisSVG.createSVGPoint(); - pt.x = x; - pt.y = y; - return pt.matrixTransform(thisSVG.getScreenCTM().inverse()); -} -``` -SVGR -``` -library(svgR) -WH<-c(48,32) -ptR<-list( - x=matrix(0,2,0) -) -R<-WH[1]*.2 -CXY=WH*c(.3,.5) - - -svgR(wh=WH, - circle(cxy=CXY+c(-R,-R), r=R/4, fill='#00FFFF'), - circle(cxy=CXY+c(-R,+R), r=R/4, fill='#00FFFF'), - circle( - cxy=CXY, - r=R, - fill='#00FFFF' - ), - rect(xy=CXY-c(0,R), wh=c(.5,.6)*WH, fill='#00FFFF'), - line(xy1=CXY-c(0,R),xy2=CXY+c(0,R), stroke='black'), - line(xy1=CXY-c(R,0),xy2=CXY, stroke='black'), - #polygon(points=WH*c(c(.1,.5),c(.25,.2),c(.25,.8)), fill='#00FFFF'), - text(cxy=WH/2, "xy") -) -``` -********************* - -POPUP -``` -add mouse click -``` -SNIPPET -``` -clicked: function(ctrlId, evt ){ - ${0:0} -} -``` -SVGR -``` -library(svgR) -WH<-c(48,32) -ptR<-list( - x=matrix(0,2,0) -) -R<-WH[1]*.2 -CXY=WH*c(.3,.5) -svgR(wh=WH, stroke="#00FFFF", fill="none", - circle(cxy=CXY+c(-R,-R), r=R/4, fill='#00FFFF'), - circle(cxy=CXY+c(-R,+R), r=R/4, fill='#00FFFF'), - g( - polygon( - points=c(WH)*c( - c(.0,.0),c(.2,.5), c(.05,.3), c(.05,.6), - c(-.05,.6),c(-.05,.3), c(-.2,.5) - ), - stroke="#00FFFF" - ), - lapply(c(0,45,135,180), function(theta){ - line(xy1=c(.1,0)*WH, xy2=c(.3,0)*WH, stroke="#00FFFF", - transform=list(rotate=-theta) - ) - }), - transform=list( translate=WH*c(.6,.45), rotate=65) - ) -) -``` - -****************** -POPUP -``` -replace node -``` -SNIPPET -``` - var htm=data.${1,value}; //value - var node=jQuery.parseHTML( htm ); - ${0,(el)}.empty().append(node); -``` -SVGR -``` -library(svgR) -WH<-c(48,32) -ptR<-list( - x=matrix(0,2,0) -) -R<-.06*WH[1] -d<-list(M=WH*c(.2,.42), Q=WH*c(c(.2,.8),c(.5,.8))) - -svgR(wh=WH, stroke.width=2, stroke="#00FFFF", fill="none", - #circle(cxy=WH*c(.2,.2), fill="#00FFFF", r=R), - #circle(cxy=WH*c(.8,.2), fill="#00FFFF", r=R), - #rect(xy=WH*c(.16,.32), fill="#00FFFF", wh=c(.6,.16)*WH), - text(xy=WH*c(.16,.38),'html', stroke.width=1, fill="#00FFFF"), - circle(cxy=WH*(c(1,1)-c(.2,.2)), r=R), - path(d=d, stroke="#00FFFF", - marker.end=marker(viewBox=c(0, 0, 10, 10), refXY=c(1,5), stroke.width=1, fill="#00FFFF", - markerWidth=4, markerHeight=5, orient="auto", - path( d=c("M", 0, 0, "L", 9, 5, "L", 0, 9, "z") ) - ) - ) -) -``` -****************** -****************** -POPUP -``` -get attribute -``` -SNIPPET -``` - var attr = $(el).attr(`${1:data-Z}`); -``` -SVGR -``` -library(svgR) -WH<-c(48,32) -ptR<-list( - x=matrix(0,2,0) -) -R<-.06*WH[1] -d<-list(M=WH*c(.2,.42), Q=WH*c(c(.2,.8),c(.5,.8))) - -svgR(wh=WH, stroke.width=2, stroke="#00FFFF", fill="none", - text(xy=WH*c(.2,.38),'attr', stroke.width=1, fill="#00FFFF"), - path(d=d, stroke="#00FFFF", - marker.end=marker(viewBox=c(0, 0, 10, 10), refXY=c(1,5), stroke.width=1, fill="#00FFFF", - markerWidth=4, markerHeight=5, orient="auto", - path( d=c("M", 0, 0, "L", 9, 5, "L", 0, 9, "z") ) - ) - ) -) -``` -****************** -****************** -POPUP -``` -get element data -``` -SNIPPET -``` - var htm=data.${1,value}; //value - var node=jQuery.parseHTML( htm ); - ${0,(el)}.empty().append(node); -``` -SVGR -``` -library(svgR) -WH<-c(48,32) -ptR<-list( - x=matrix(0,2,0) -) -R<-.06*WH[1] -d<-list(M=WH*c(.8,.42), Q=WH*c(c(.8,.8),c(.2,.8))) - -svgR(wh=WH, #stroke.width=1, stroke="#00FFFF", fill="none", - polygon(points=WH*c(c(.05,.5), c(.15,.3),c(.15,.7)),fill='#00FFFF'), - rect(cxy=WH*c(.2,.5), wh=WH*c(.1,.1),fill="#00FFFF"), - lapply(1:5, function(i){ - ellipse( - cxy=c(.6, .8-i*.1)*WH, - rxy=c(.2,.1)*WH, - stroke='black', - fill='#00FFFF', - stroke='black', - stroke.width=.5 - ) - }) -) -``` -****************** - -****************** -POPUP -``` -set element data -``` -SNIPPET -``` - var htm=data.${1,value}; //value - var node=jQuery.parseHTML( htm ); - ${0,(el)}.empty().append(node); -``` -SVGR -``` -library(svgR) -WH<-c(48,32) -ptR<-list( - x=matrix(0,2,0) -) -R<-.06*WH[1] -d<-list(M=WH*c(.8,.85), Q=WH*c(c(.12,.85),c(.12,.52))) - -svgR(wh=WH, #stroke.width=1, stroke="#00FFFF", fill="none", - polygon(points=WH*c(c(.25,.5), c(.15,.3),c(.15,.7)),fill='#00FFFF'), - rect(cxy=WH*c(.1,.5), wh=WH*c(.1,.1),fill="#00FFFF"), - lapply(1:5, function(i){ - ellipse( - cxy=c(.6, .8-i*.1)*WH, - rxy=c(.2,.1)*WH, - stroke='black', - fill='#00FFFF', - stroke='black', - stroke.width=.5 - ) - }) -) -``` - -********************* - - -********************* - - -POPUP -``` -To string -``` -SNIPPET -``` -JSON.stringify(${1:obj}) -``` -SVGR -``` -library(svgR) -WH<-c(48,32) -ptR<-list( - x=matrix(0,2,0) -) -r=WH[2]/3 -lft=WH[1]/2-1.5*r -top<-WH[2]/2-r -bot<-WH[2]/2+r -svgR(wh=WH, - polygon(points=WH*c(c(.25,.5), c(.15,.3),c(.15,.7)),fill='#00FFFF'), - rect(cxy=WH*c(.1,.5), wh=WH*c(.1,.1),fill="#00FFFF"), - circle( - cxy=WH/2, - r=WH[2]/3, - stroke='none', - fill='#00FFFF' - ), - path( - d=list( - M=c(.4,.8)*WH, - C=c( c(.6,1.2),c(.9,.2), c(.8,.9))*WH - ), - stroke='#00FFFF', - stroke.width=1, - fill='none' - ), - g( - lapply(1:3, function(i){ - ellipse(cxy=WH*c(.5, .1), rxy=i*c(8,3), fill='none', stroke='#000000', stroke.width=.5) - }), - mask=mask(circle(cxy=WH/2, r=WH[2]/3), fill='white' ) - ), - g( - lapply(1:5, function(i){ - ellipse(cxy=WH*c(.7, .5), rxy=i*c(3,5), fill='none', stroke='#000000', stroke.width=.5) - }), - mask=mask( - circle(cxy=WH/2, r=WH[2]/3, fill='white'), - ellipse(cxy=WH*c(.5, .1), rxy=3*c(8,3), fill='black') - ) - ), - g( - lapply(1:5, function(i){ - ellipse(cxy=WH*c(.3, .3), rxy=i*c(3,5), fill='none', stroke='#000000', stroke.width=.5) - }), - mask=mask( - circle(cxy=WH/2, r=WH[2]/3, fill='white'), - ellipse(cxy=WH*c(.5, .1), rxy=3*c(8,3), fill='black'), - ellipse(cxy=WH*c(.7, .5), rxy=5*c(3,5), fill='black') - ) - ) -) -``` -********************* - - -POPUP -``` -From string -``` -SNIPPET -``` -JSON.parse(${1:obj}) -``` -SVGR -``` -library(svgR) -WH<-c(48,32) -ptR<-list( - x=matrix(0,2,0) -) -r=WH[2]/3 -lft=WH[1]/2-1.5*r -top<-WH[2]/2-r -bot<-WH[2]/2+r -svgR(wh=WH, - polygon(points=WH*c(c(.05,.5), c(.15,.3),c(.15,.7)),fill='#00FFFF'), - rect(cxy=WH*c(.2,.5), wh=WH*c(.1,.1),fill="#00FFFF"), - circle( - cxy=WH/2, - r=WH[2]/3, - stroke='none', - fill='#00FFFF' - ), - path( - d=list( - M=c(.4,.8)*WH, - C=c( c(.6,1.2),c(.9,.2), c(.8,.9))*WH - ), - stroke='#00FFFF', - stroke.width=1, - fill='none' - ), - g( - lapply(1:3, function(i){ - ellipse(cxy=WH*c(.5, .1), rxy=i*c(8,3), fill='none', stroke='#000000', stroke.width=.5) - }), - mask=mask(circle(cxy=WH/2, r=WH[2]/3), fill='white' ) - ), - g( - lapply(1:5, function(i){ - ellipse(cxy=WH*c(.7, .5), rxy=i*c(3,5), fill='none', stroke='#000000', stroke.width=.5) - }), - mask=mask( - circle(cxy=WH/2, r=WH[2]/3, fill='white'), - ellipse(cxy=WH*c(.5, .1), rxy=3*c(8,3), fill='black') - ) - ), - g( - lapply(1:5, function(i){ - ellipse(cxy=WH*c(.3, .3), rxy=i*c(3,5), fill='none', stroke='#000000', stroke.width=.5) - }), - mask=mask( - circle(cxy=WH/2, r=WH[2]/3, fill='white'), - ellipse(cxy=WH*c(.5, .1), rxy=3*c(8,3), fill='black'), - ellipse(cxy=WH*c(.7, .5), rxy=5*c(3,5), fill='black') - ) - ) -) -``` - -********************* - - -POPUP -``` -LOG -``` -SNIPPET -``` -console.log(${1:'text '+} ${0:value}); -``` -SVGR -``` -library(svgR) -WH<-c(48,32) -ptR<-list( - x=matrix(0,2,0) -) -svgR(wh=WH, - rect(xy=c(.3,.35)*WH, wh=WH*c(.5,.3), fill='#00FFFF'), - ellipse( - cxy=c(.8,.5)*WH, - rxy=c(.05,.15)*WH, - fill='#00FFFF' - ), - ellipse( - cxy=c(.3,.5)*WH, - rxy=c(.05,.15)*WH, - fill='#00FFFF', - stroke='black', - stroke.width=.5 - ), - ellipse( - cxy=c(.3,.5)*WH, - rxy=.5*c(.05,.15)*WH, - fill='#00FFFF', - stroke='black', - stroke.width=.5 - ), - polygon(points=c( c(.5,.35), c(.6,.4), c(.7,.2), c(.6,.15))*WH, - fill='#00FFFF') -) -``` -********************* - -POPUP -``` -Trigger -``` -SNIPPET -``` -${1:$(el)}.trigger(${0:"change"}); -``` -SVGR -``` -library(svgR) -WH<-c(48,32) -ptR<-list( - x=matrix(0,2,0) -) -X=c(.2,.4,.6,.8) -D<-list( - M=c(.2,.2), - Q=c( ) -) -svgR(wh=WH, #stroke.width=1, stroke="#00FFFF", fill="none", - path(d=c("M",c(10,5), "Q", c(5,20), c(25,25) , "T", c(40,5)) , fill='#00FFFF'), - path(d=c("M",c(12,8), "Q", c(8,20), c(25,22) , "T", c(36,8)) , fill='black'), - path(d=c( "M", c(24,8), "C", c(22,10), c(30,10), c( 18,18), "Q" , c(30,15), c(28,10), c(32,10), c(32,8)),fill='#00FFFF') - - -) -``` -****************** - - - - diff --git a/inst/App/projectTemplates/shinyInput/aux/dnds/sampleShapes.dnds b/inst/App/projectTemplates/shinyInput/aux/dnds/sampleShapes.dnds deleted file mode 100644 index 0034e180..00000000 --- a/inst/App/projectTemplates/shinyInput/aux/dnds/sampleShapes.dnds +++ /dev/null @@ -1,527 +0,0 @@ ---- -title: "Samples" -author: "Anonymous" -date: "TODAY" -output: dnd_snippet ---- - -- Individual drippets are seperate by lines consisting of three or more stars (*) -- Each drippet consists of 3 entries, with each entry having a title and a value (block) -- The title consists of a single line followed by a colon (:) -- titles are *Hint:*, *SNIPPET*, *SVGR* - - The values are blocks defined by 3 backtics *````* - - Two drippets are shown below to help you get started - -********************* - - -POPUP -``` -Sample Circle -``` -SNIPPET -``` -circle( - cxy=${1:WH/2}, - r=${2:WH[2]/3}, - stroke='black', - fill=${3:'none'} -)${0:} -``` -SVGR -``` -library(svgR) -WH<-c(48,32) -ptR<-list( - x=matrix(0,2,0) -) -svgR(wh=WH, -#your custom code goes here - circle( - cxy=WH/2, - r=WH[2]/3, - stroke='#00FFFF', - stroke.width=2, - fill='none' - ) -) -``` -********************* - - - -POPUP -``` -Sample Ellipse -``` -SNIPPET -``` -ellipse( - cxy=${1:WH/2}, - rxy=${2:c(.4,.3)*WH}, - stroke=${3:'black'}, - fill=${4:'none'} -)${0:} -``` -SVGR -``` -library(svgR) -WH<-c(48,32) -ptR<-list( - x=matrix(0,2,0) -) -svgR(wh=WH, -#your custom code goes here - ellipse( - cxy=WH/2, - rxy=c(.3,.2)*WH, - stroke='#00FFFF', - stroke.width=2, - fill='none' - ) -) -``` -********************* - -********************* - - - -POPUP -``` -Sample Rectangle -``` -SNIPPET -``` -rect( - xy=${1:WH/2}, - wh=${2:c(.47,.3)*WH}, - stroke='black', - fill=${3:'none'} -)${0:} -``` -SVGR -``` -library(svgR) -WH<-c(48,32) -ptR<-list( - x=matrix(0,2,0) -) -svgR(wh=WH, - line(xy1=c(.5,0)*WH, xy2=c(.5,1)*WH, stroke.dasharray=2, stroke="#00FFFF"), - line(xy1=c(0,.5)*WH, xy2=c(1,.5)*WH, stroke.dasharray=2, stroke="#00FFFF"), - rect( - xy=WH/2, - wh=c(.4,.2)*WH, - stroke='#00FFFF', - stroke.width=2, - fill='none' - ) -) -``` -********************* - - - - -POPUP -``` -Sample Centered Rectangle -``` -SNIPPET -``` -rect( - cxy=${1:WH/2}, - wh=${2:c(.47,.3)*WH}, - stroke='black', - fill=${3:'none'} -)${0:} -``` -SVGR -``` -library(svgR) -WH<-c(48,32) -ptR<-list( - x=matrix(0,2,0) -) -svgR(wh=WH, - line(xy1=c(.5,0)*WH, xy2=c(.5,1)*WH, stroke.dasharray=2, stroke="#00FFFF"), - line(xy1=c(0,.5)*WH, xy2=c(1,.5)*WH, stroke.dasharray=2, stroke="#00FFFF"), - rect( - cxy=WH/2, - wh=c(.4,.2)*WH, - stroke='#00FFFF', - stroke.width=2, - fill='none' - ) -) -``` -********************* -********************* -POPUP -``` -Sample Line Segment -``` -SNIPPET -``` -line( - xy1=${1:c(0,0)}, - xy2=${2:WH}, - stroke=${3:'black'} -)${0:} -``` -SVGR -``` -library(svgR) -WH<-c(48,32) -ptR<-list( - x=matrix(0,2,0) -) -svgR(wh=WH, - line( - xy1=c(.2,0.8)*WH, - xy2=c(.8,0.2)*WH, - stroke='#00FFFF', - stroke.width=2 - ) -) -``` -********************* -********************* -POPUP -``` -Sample PolyLine (Connected Line Segments) -``` -SNIPPET -``` -polyline( - points=${1:WH*matrix(c(.25,.25,.5,.5,.75,.25),2)}, - stroke=${2:'black'}, - stroke.width=${2:1}, - fill=${3:'none'} -)${0:} -``` -SVGR -``` -library(svgR) -WH<-c(48,32) -ptR<-list( - x=matrix(0,2,0) -) -svgR(wh=WH, - polyline( - points=WH*matrix(c(.25,.25,.5,.8,.75,.25),2), - stroke.width=2, - stroke='#00FFFF', - fill='none' - ) -) -``` -********************* -********************* -POPUP -``` -Sample Polygon -``` -SNIPPET -``` -polygon( - points=${1:WH*matrix(c(.25,.75,.5,.5,.75,.75),2)}, - stroke=${2:'black'}, - stroke.width=${2:1}, - fill=${3:'none'} -)${0:} -``` -SVGR -``` -library(svgR) -WH<-c(48,32) -ptR<-list( - x=matrix(0,2,0) -) -svgR(wh=WH, - polygon( - points=WH*matrix(c(.25,.75,.5,.25,.75,.75),2), - stroke='#00FFFF', - stroke.width=2, - fill='none' - ) -) -``` -********************* -********************* -POPUP -``` -Sample Text -``` -SNIPPET -``` -text( - ${1:'hello world'}, - xy=${2:WH/2}, - stroke=${3:'black'}, - font.size=${4:36}, - fill=${5:'none'} -)${0:} -``` -SVGR -``` -library(svgR) -WH<-c(48,32) -ptR<-list( - x=matrix(0,2,0) -) -svgR(wh=WH, - line(xy1=c(.5,0)*WH, xy2=c(.5,1)*WH, stroke.dasharray=2, stroke="#00FFFF"), - line(xy1=c(0,.5)*WH, xy2=c(1,.5)*WH, stroke.dasharray=2, stroke="#00FFFF"), - text( - 'Text', - xy=WH/2, - stroke='#00FFFF', - font.size=10, - fill='#00FFFF' - ) -) -``` -********************* -********************* -POPUP -``` -Sample Text -``` -SNIPPET -``` - text( - ${1:'hello world'}, - cxy=${2:WH/2}, - stroke=${3:'black'}, - font.size=${4:36}, - fill=${5:'none'} - )${0:} -``` -SVGR -``` -library(svgR) -WH<-c(48,32) -ptR<-list( - x=matrix(0,2,0) -) -svgR(wh=WH, - line(xy1=c(.5,0)*WH, xy2=c(.5,1)*WH, stroke.dasharray=2, stroke="#00FFFF"), - line(xy1=c(0,.5)*WH, xy2=c(1,.5)*WH, stroke.dasharray=2, stroke="#00FFFF"), - text( - 'Text', - cxy=WH/2, - stroke='#00FFFF', - font.size=10, - fill='#00FFFF' - ) -) -``` -********************* -****************** -POPUP -``` -Sample Arc -``` -SNIPPET -``` - path( - d=list( - M=${1:c(.5,.2)*WH}, - A=${2:c(2.3*WH, 180,1,0,c(.8,.5)*WH)} - ), - stroke=${3:'#0000FF'}, - stroke.width=${4:2}, - fill=${5:'none'} - )${0:} -``` -SVGR -``` -library(svgR) -WH<-c(48,32) -# Defined by mouse: edit with care! -ptR<-list( - x=tribble( - ~points, - matrix(NA,2,0) - ) -) -svgR(wh=WH, - path( - d=list( - M=c(.5,.2)*WH, - A=c(.3*WH, 180,1,0,c(.8,.5)*WH) - ), - stroke='#00FFFF', - stroke.width=2, - fill='none' - ) -) -``` -*********************** -****************** -POPUP -``` -Sample Quadratic Bezier -``` -SNIPPET -``` -path( - d=list( - ${1:M=c(.2,.2)*WH,} - Q=${2:c( c(.5,1.5),c(.8,.2))*WH} - ), - stroke=${3:'#000FF'}, - stroke.width=${4:1}, - fill=${5:'none'} -)${0:} -``` -SVGR -``` -library(svgR) -WH<-c(48,32) -# Defined by mouse: edit with care! -ptR<-list( - x=tribble( - ~points, - matrix(NA,2,0) - ) -) -svgR(wh=WH, - path( - d=list( - M=c(.2,.2)*WH, - Q=c( c(.5,1.5)*WH,c(.8,.2)*WH) - ), - stroke='#00FFFF', - stroke.width=2, - fill='none' - ) -) -``` -*********************** -****************** -POPUP -``` -Sample Extended Quadratic Bezier -``` -SNIPPET -``` -path( - d=list( - ${1:M=c(.3,.1)*WH,} - Q=${2:c( c(1,.7),c(.5,.7))*WH}, - T=${3:c(.7,.1)*WH} - ), - stroke=${4:'#0000FF'}, - stroke.width=${5:1}, - fill=${6:'none'} -)${0:} -``` -SVGR -``` -library(svgR) -WH<-c(48,32) -# Defined by mouse: edit with care! -ptR<-list( - x=tribble( - ~points, - matrix(NA,2,0) - ) -) -svgR(wh=WH, - path( - d=list( - M=c(.3,.1)*WH, - Q=c( c(1,.7),c(.5,.7))*WH, - T=c(.7,.1)*WH - ), - stroke='#00FFFF', - stroke.width=2, - fill='none' - ) -) -``` -*********************** - -POPUP -``` -Sample Cubic Bezier -``` -SNIPPET -``` -path( - d=list( - ${1:M=c(.2,.9)*WH,} - C=${2:c( c(.3,-1),c(.7,2), c(.8,.2))*WH} - ), - stroke=${3:'#0000FF'}, - stroke.width=${4:1}, - fill=${5:'none'} -)${0:} -``` -SVGR -``` -library(svgR) -WH<-c(48,32) -ptR<-list( - x=matrix(0,2,0) -) -svgR(wh=WH, -#your custom code goes here - path( - d=list( - M=c(.2,.9)*WH, - C=c( c(.3,-1),c(.7,2), c(.8,.2))*WH - ), - stroke='#00FFFF', - stroke.width=2, - fill='none' - ) -) -``` -********************* -*********************** - -POPUP -``` -Sample Extended Cubic Bezier -``` -SNIPPET -``` -path( - d=list( - M=c(.2,.6)*WH, - C=c( c(.4,.0),c(.4,.8), c(.5,.8))*WH, - S=c( c(.6,.0),c(.8,.6))*WH - ), - stroke=${3:'#0000FF'}, - stroke.width=${4:1}, - fill=${5:'none'} -)${0:} -``` -SVGR -``` -library(svgR) -WH<-c(48,32) -ptR<-list( - x=matrix(0,2,0) -) -svgR(wh=WH, -#your custom code goes here - path( - d=list( - M=c(.2,.6)*WH, - C=c( c(.4,.0),c(.4,.8), c(.5,.8))*WH, - S=c( c(.6,.0),c(.8,.6))*WH - ), - stroke='#00FFFF', - stroke.width=2, - fill='none' - ) -) -``` -********************* - - diff --git a/inst/App/projectTemplates/shinyInput/circularArc.R b/inst/App/projectTemplates/shinyInput/circularArc.R deleted file mode 100644 index 87da31a3..00000000 --- a/inst/App/projectTemplates/shinyInput/circularArc.R +++ /dev/null @@ -1,36 +0,0 @@ -library(svgR) -library(tidyverse) -WH<-c(600,400) - -# Defined by mouse: edit with care! -ptR<-list( - x= tribble( - ~points, - matrix(0,2,0) - ) -) - - -pieShape<-function(cxy, R=min(cxy), theta1=0, theta2=2*pi){ - P0=c(cos(theta1),-sin(theta1))*R+cxy - P1=c(cos(theta2),-sin(theta2))*R+cxy - largeArc=ifelse( (theta2-theta1)>pi, 1,0) - sf=0 - d=list( - M=P0, - A=c( c(R,R), 0, largeArc, sf, P1) - ) -} - -R=100 - -svgR(wh=WH, - #your custom code goes here - circle(cxy=WH/2, R=R, fill='lightblue') , - path( - d=pieShape(cxy=WH/2,R=R, 0, 3*pi/4), - stroke='#0000FF', - stroke.width=20, - fill='none' - ) -) diff --git a/inst/App/projectTemplates/shinyInput/pieShape.R b/inst/App/projectTemplates/shinyInput/pieShape.R deleted file mode 100644 index f7b6afb9..00000000 --- a/inst/App/projectTemplates/shinyInput/pieShape.R +++ /dev/null @@ -1,36 +0,0 @@ -library(svgR) -library(tidyverse) -WH<-c(600,600) - -# Defined by mouse: edit with care! -ptR<-list( - x= tribble( - ~points, - matrix( c(c(69,71)), 2), - matrix(0,2,0) - ) -) - - -pieShape<-function(cxy, R=min(cxy), theta1=0, theta2=2*pi){ - P0=c(cos(theta1),-sin(theta1))*R+cxy - P1=c(cos(theta2),-sin(theta2))*R+cxy - largeArc=ifelse( (theta2-theta1)>pi, 1,0) - sf=0 - d=list( - M=cxy, - L=P0, - A=c( c(R,R), 0, largeArc, sf, P1), - Z=0 - ) -} - -svgR(wh=WH, - #your custom code goes here - path( - d=pieShape(cxy=WH/2,R=100, 0, 3*pi/2), - stroke='#0000FF', - stroke.width=2, - fill='lightblue' - ) -) diff --git a/inst/App/projectTemplates/shinyInput/pieShape2.R b/inst/App/projectTemplates/shinyInput/pieShape2.R deleted file mode 100644 index dc2cb521..00000000 --- a/inst/App/projectTemplates/shinyInput/pieShape2.R +++ /dev/null @@ -1,38 +0,0 @@ -library(svgR) -library(tidyverse) -WH<-c(600,400) - -# Defined by mouse: edit with care! -ptR<-list( - x= tribble( - ~points, - matrix(0,2,0) - ) -) - -pieShape2<-function(cxy, R=min(cxy), thetas=c(0,2*pi), dR=30){ - thetas=sort(thetas%%(2*pi)) - RI=R-dR - P=t(matrix(c( cos(thetas), -sin(thetas)),2)) - PP=P*RI + cxy - P= P*R +cxy - largeArc=ifelse(diff(thetas)>pi,1,0) - sf=0 - d=list( - M=P[,1], - A=c( c(R,R), 0, largeArc, sf, P[,2]), - L=PP[,2], - A=c( c(RI,RI), 0, largeArc, 1-sf, PP[,1]), - Z=0 - ) -} - -svgR(wh=WH, - #your custom code goes here - path( - d=pieShape2(cxy=WH/2,R=100, thetas=c(0, 5*pi/4)), - stroke='#0000FF', - stroke.width=2, - fill='lightblue' - ) -) diff --git a/inst/App/projectTemplates/shinyInput/shinyInputCntrl.R b/inst/App/projectTemplates/shinyInput/shinyInputCntrl.R deleted file mode 100644 index c502b160..00000000 --- a/inst/App/projectTemplates/shinyInput/shinyInputCntrl.R +++ /dev/null @@ -1,104 +0,0 @@ -library(shiny) -library(svgR) -library(jsonlite) - -try({ removeInputHandler("shinyInputCntrlBinding") }) - -#helper functions - -Normalize<-function(Z){ - S2<-sum(Mod(Z)^2) - if(S2>0){ - Z<-Z/sqrt(S2) - } - Z -} - -# use toJSON for non-trivial initialization -ZtoJSON<-function(Z){ - toJSON(data.frame(re=Re(Z),im=Im(Z))) -} - -# wrapper around svgR code -shinyInputSvgCntrl<-function(params){ - source('shinyInput_svg.R', local=T)$value -} - -# return svg given params -newShinyInputCntrl<-function(ID, WH, CMDS, Z){ - svg<-shinyInputSvgCntrl( - params=list(ID=ID, WH=WH, CMDS=CMDS, Z=Z ) - ) - tmp<-HTML(as.character(svg)) - return(tmp) -} - -# definition of what to call for the given mouse events -id2CMDS<-function(inputId){ - c( - sprintf('shinyInputCntrlBinding.clicked("%s", %d, evt);',inputId, 0 ), - sprintf('shinyInputCntrlBinding.clicked("%s", %d, evt);',inputId, 1 ) - ) -} - -# Cntrl constructor to insert in app ui -shinyInputCntrl<-function(inputId, wh=c(50,100), Z=c(1+0i, 1+1i) ){ - Z<-Normalize(Z) - #CMDS<-paste0("alert('qubit |", c(0,1), "> selected')") - CMDS=id2CMDS(inputId) - - tagList( - singleton(tags$head(tags$script(src = "shinyInput.js"))), - div( id=inputId, - class="shinyInputCntrl", - # customize for initializationby attaching property(s) to this div - 'data-Z'=ZtoJSON(Z), - newShinyInputCntrl(ID=inputId, WH=wh, CMDS=CMDS, Z=Z) - ) - ) -} - -# server to client update -updateShinyInputCntrl<-function(session, inputId, wh=c(200,400), Z=NULL){ - # validate input - if(length(Z)!=2){ - cat('bad dim') - return(NULL) - } - - # normalize first - Z<-Normalize(Z) - # CMDS<-paste0("alert('qubit |", c(0,1), "> selected')") - CMDS=id2CMDS(inputId) - #recreate the entire svg - node<-as.character(newShinyInputCntrl(ID=inputId, WH=wh, CMDS=CMDS, Z=Z)) - mssg<-list(value=node, Z=ZtoJSON(Z)) - session$sendInputMessage(inputId, mssg) -} - - -# preprocess data returned to server from the client -shiny::registerInputHandler( - "shinyInputCntrlBinding", - function(value, shinysession, inputId) { - if(is.null(value) ) { - return("NULL") - } else { - ZDF<-fromJSON(value$Z) - print(ZDF) - if(nrow(ZDF)<2){ - return(NULL) - } - Z=complex(nrow(ZDF), ZDF$re, ZDF$im) - Index=1+value$Index - L<-1-sum(Mod(Z[ Index])^2) - LL<- sum(Mod(Z[-Index])^2) - Z[-Index]<-sqrt(L/LL)*Z[-Index] - print("ZZ") - print(Z) - updateShinyInputCntrl(shinysession, inputId, wh=c(200,400), Z=Z) - return(Z) - } - } -) - diff --git a/inst/App/projectTemplates/shinyInput/shinyInput_svg.R b/inst/App/projectTemplates/shinyInput/shinyInput_svg.R deleted file mode 100644 index b85815db..00000000 --- a/inst/App/projectTemplates/shinyInput/shinyInput_svg.R +++ /dev/null @@ -1,69 +0,0 @@ -library(svgR) -library(tidyverse) - -#-------- params ---------------------- -#` default params -WH<-c(400,800) -CMDS<-paste0("alert('|", c(0,1), "> selected')") -Z<-c( 0+1i, 1-0i) -L<-sqrt(sum(Mod(Z)^2)) -Z<-Z/L -ID<-'myQubitbit' - -#----------function override of params---------- -if(exists("params") ){ - for(n in names(params)){ - assign(n, params[[n]]) - } -} - -#-----any R helper code goes here-------------------------- - - -pieShape<-function(cxy, R=1, thetas=c(0, 2*pi)){ - thetas<-sort(thetas%%(2*pi)) - P<-t(matrix( c(cos(thetas), -sin(thetas)),2)) - P<-P*R+cxy - largeArc=0 - sf=ifelse( diff(thetas)>=pi, 1,0) - d=list( - M=cxy, - L=P[,1], - A=c( c(R,R), 0, largeArc, sf, P[,2]), - Z=0 - ) -} - -stroke.width=10/WH[1] - - -cmplx % - - - - - - diff --git a/inst/App/projectTemplates/shinyInput/www/shinyInput.js b/inst/App/projectTemplates/shinyInput/www/shinyInput.js deleted file mode 100644 index 7d4fa9c2..00000000 --- a/inst/App/projectTemplates/shinyInput/www/shinyInput.js +++ /dev/null @@ -1,78 +0,0 @@ -// JAVASCRIPT - -//INPUT BINDING -var shinyInputCntrlBinding = new Shiny.InputBinding(); -$.extend(shinyInputCntrlBinding, { - find: function(scope) { - console.log('find'); - return $(scope).find(".shinyInputCntrl"); - }, - initialize: function(el){ - // Initialize any data values here - // here we initial Z and the current Index - let iniZ=$(el).attr(`data-Z`); //extract attribute - $(el).data("Z", JSON.parse(iniZ)); //convert to an object and attach - $(el).data('Index',0); // set index - }, - getValue: function(el) { - // used to return the value of this input control - // here we Z and which index was changed - return { - Z: JSON.stringify($(el).data('Z')), - Index: $(el).data('Index') - }; - }, - setValue: function(el, index, value) { - // used for updating input control - let Z=$(el).data("Z"); - $(el).index=index; - Z[index]={ - re:value[0], - im:value[1] - } - $(el).data('Z',Z); - $(el).data('Index',index); - $(el).trigger("change"); - }, - subscribe: function(el, callback) { - // notify server whenever change - $(el).on("change.shinyInputCntrlBinding", function(e) { - callback(); - }); - }, - unsubscribe: function(el) { - $(el).off(".shinyInputCntrlBinding"); - }, - receiveMessage: function(el, data) { //called by server when updating - if(!!data.value){ - var htm=data.value; //htm is string represented a node - var node=jQuery.parseHTML( htm ); - $(el).empty().append(node); - - $(el).data("Z", data.Z); - // alternatively, set value but be careful about index - } - }, - mouse2pt: function(id, x, y){ //method to convert mouse coord to svg coord - var thisSVG=document.querySelector("#" + id ); - thisSVG=document.querySelector("svg#" + id ); - var pt= thisSVG.createSVGPoint(); - pt.x = x; - pt.y = y; - return pt.matrixTransform(thisSVG.getScreenCTM().inverse()); - }, - clicked: function(ctrlId, index, evt){ - let svgId=ctrlId + index; - let pt = this.mouse2pt(svgId, evt.clientX, evt.clientY); - let el = "#" + ctrlId; - let value =[pt.x, - pt.y] ; - this.setValue(el, index, value); - }, - getType: function(el){ - return "shinyInputCntrlBinding"; - } -}); - -// REGISTER INPUT BINDING -Shiny.inputBindings.register(shinyInputCntrlBinding); - diff --git a/inst/App/rightPanel/choiceSet/cmdChoiceSetImport.R b/inst/App/rightPanel/choiceSet/cmdChoiceSetImport.R new file mode 100644 index 00000000..5cdb9136 --- /dev/null +++ b/inst/App/rightPanel/choiceSet/cmdChoiceSetImport.R @@ -0,0 +1,27 @@ +cmdChoiceSetImport<-function(){ + click('buttonChoiceSetImport') +} + +observeEvent(input$buttonChoiceSetImport,{ + fp.dt<-parseFilePaths(c(home='~'), input$buttonChoiceSetImport) + if(length(fp.dt)>0 && nrow(fp.dt)){ + datapath<-as.character(fp.dt$datapath[1]) + datapath<-gsub(pattern = '^NA/', "~/", datapath) + # copy to aux + # get targetDir + targetDir<-getAuxChoicesPath() + if(!file.exists(targetDir)){ # we should probably place this elsewhere !!! + dir.create(targetDir, recursive=TRUE) + } + + targetName<-basename(datapath) + + target<-file.path(targetDir,targetName ) + + # file copy + file.copy(datapath, target, TRUE) + # relaod + readAuxChoices(targetDir) + } +}) + diff --git a/inst/App/rightPanel/choiceSet/modalChoiceSet.R b/inst/App/rightPanel/choiceSet/modalChoiceSet.R new file mode 100644 index 00000000..d62384ef --- /dev/null +++ b/inst/App/rightPanel/choiceSet/modalChoiceSet.R @@ -0,0 +1,124 @@ +cmdCustColumnEdit<-function( custColumnName){ + showModal( + modalCustColumnEditor(custColumnName=custColumnName) + ) +} + +# todo + + +modalCustColumnEditor <- function( custColumnName, value="TRUE\nFALSE" ) { + #CustColumnModalType(type) + modalDialog( + div( id='custColumnBackPanelModalEdit', class='backPanel', style='padding:20px;', + textInput("modalCustColumnName", + label=span(style='color: #00ffff;', 'Name'), + value=custColumnName, + width='100%', + placeholder = 'Enter a name with at least 6 characters for this set of choices ' + ), + div( + aceEditor( + outputId="customColumnChoiceTxt", + height = "380px", + mode='r', + value=value + ) + ) + ), + title="CustColumn Editor", + easyClose = TRUE, + footer = tagList( + modalButton("Dismiss"), + actionButton("modalCustColumnEditorCommitOk", "Commit") + ) + ) +} + +observeEvent(input$modalCustColumnName,{ + CustColumnName<-input$modalCustColumnName + #if(length(CustColumnName)==0 || nchar(CustColumnName)<6 || CustColumnName %in% names(allWidgetChoices)){ + if(!goodRName(CustColumnName,5) || CustColumnName %in% allWidgetNames){ + hideElement("modalCustColumnEditorCommitOk") + } else { + showElement("modalCustColumnEditorCommitOk") + } +}) + +getAuxChoicesPath<-reactive({file.path(getDirPath(),'aux','choices')}) + +writeAuxCustColumnList<-function(filePath, customColumnChoiceList){ + cat(customColumnChoiceList, file=filePath) +} + +readAuxChoices<-function(filePath){ + files<-dir(getAuxChoicesPath(), pattern="*\\.txt$",full.names=TRUE ) + customChoiceList<-list() + customChoiceList<-lapply(files, function(f){ + scan(file=f, what=character(), quiet=TRUE, sep="\n") + }) + nms<-gsub('\\.txt','', basename(files)) + names(customChoiceList)<-nms + aux$colChoiceSet<-customChoiceList +} + + + + +observeEvent( input$modalCustColumnEditorCommitOk,{ + + CustColumnName<-input$modalCustColumnName + CustColumnName<-sub('\\.txt$','',CustColumnName) + CustColumnName<-paste0(CustColumnName,'.txt') + + customColumnChoiceList<-input$customColumnChoiceTxt + if(!dir.exists(getAuxChoicesPath())){ + dir.create(getAuxChoicesPath() ) + } + filePath<-file.path(getAuxChoicesPath(), CustColumnName) + writeAuxCustColumnList(filePath, customColumnChoiceList) + readAuxChoices() + removeModal() +}) + +aux<-reactiveValues(colChoiceSet=list()) + +getChoiceSetElements<-function(name){ + rtv<-NULL + if(length(name)==1){ + cs<-aux$colChoiceSet + rtv<- cs[[name]] + } + rtv +} + + +observeEvent(aux$colChoiceSet,{ + # reset submenu for dropDown-cmdEditColumnChoices + if(length(aux$colChoiceSet )==0){ + removeDMDM(session, 'plotNavBar','Edit Choices') + } else{ + kids<-lapply(names(aux$colChoiceSet), function(nn){ + shinyDMDMenu::menuItem(nn, value=paste0('editChoiceSet-',nn)) + }) + if(length(kids)>0){ + + afterEntry='cmdNewColumnChoices' + label=paste0('Edit Choices') + shinyDMDMenu::removeDMDM(session, "plotNavBar", 'Edit Choices') + shinyDMDMenu::insertAfterDMDM( + session, + menuBarId ="plotNavBar", + entry=afterEntry, + submenu= + do.call( + function(...){ subMenuDropdown( label,...) }, + kids + ) + ) + enableDMDM(session, 'plotNavBar','Edit Choices') + } + } +}) + + diff --git a/inst/App/rightPanel/footer/moduleFooterRight.R b/inst/App/rightPanel/footer/moduleFooterRight.R index 8069dd9b..590b8b5f 100644 --- a/inst/App/rightPanel/footer/moduleFooterRight.R +++ b/inst/App/rightPanel/footer/moduleFooterRight.R @@ -7,15 +7,25 @@ moduleFooterRight<-function(input, output, session, getTibEditState, getPointMax, getPanelState, - hasPreProcChoices + hasPreProcChoices, + getScriptName ){ output$footer<-renderUI({ footerPanelState<-getPanelState() if(hasPreProcChoices()){ leftPtButtons= 50 + scriptName=getScriptName() + if(length(scriptName)>0){ + scriptName=paste("Preproc:", scriptName) + } else { + scriptName="" + } + + } else { leftPtButtons= 0 + scriptName='' } if(!is.null( footerPanelState )){ @@ -32,7 +42,8 @@ moduleFooterRight<-function(input, output, session, span(span('class'="icon-circle"), span('class'="icon-fork")) %>% bs_embed_tooltip(title = "Split Select") ), status='primary' - ) + ), + span( scriptName, class='ptRFootertText', inline=TRUE) ), absolutePanel( right=90, bottom=10, width=110, absolutePanel( left=0, bottom=0, 'class'='ptR2', style="font-weight: bold; color: #00FFFF;", span('max pts/row:')), @@ -53,7 +64,8 @@ moduleFooterRight<-function(input, output, session, span(span('class'="icon-window-minimize"), span('class'="icon-clone")) %>% bs_embed_tooltip(title = "Clone Row") ), status='primary' - ) + ), + span( scriptName, class='ptRFootertText', inline=TRUE) ) ) } else if (footerPanelState=='value'){ @@ -62,11 +74,13 @@ moduleFooterRight<-function(input, output, session, actionGroupButtons( inputIds=c(session$ns("tagSetValue" )), labels=list( - span(span('class'="icon-right"), span('class'="icon-columns")) %>% bs_embed_tooltip(title = "Set Value") - ), + span(span('class'="icon-right"), span('class'="icon-columns")) %>% bs_embed_tooltip(title = "Set Selected to Value") + ) , status='primary' - ) + ), + span( scriptName, class='ptRFootertText', inline=TRUE) ) + ) } else { NULL diff --git a/inst/App/rightPanel/footer/serverFooterRight.R b/inst/App/rightPanel/footer/serverFooterRight.R index 7e866511..82212fa9 100644 --- a/inst/App/rightPanel/footer/serverFooterRight.R +++ b/inst/App/rightPanel/footer/serverFooterRight.R @@ -12,7 +12,10 @@ returnValue4ModuleRtFtr<-callModule( rtv<-getRightMidPanel(); rtv }), - hasPreProcChoices=hasPreProcChoices + hasPreProcChoices=hasPreProcChoices , + getScriptName=reactive({ + getPreProcScriptName(tab_Id=getTibTabId(), tib_Name=getAssetName(),column_Name= getTibColumnName()) + }) ) #-----------BUTTON EVENTS-------------------- @@ -29,7 +32,7 @@ observeEvent( updateRowPicker(session, "myTibRowCntrl", insertRow=rowIndex+1, selectRow=rowIndex+1) newTib<-bind_rows(tib[1:rowIndex,], tib[rowIndex:nrow(tib),]) rowIndex=rowIndex+1 - matCol<-ncol(newTib[[rowIndex, getTibPtColPos()]]) + matCol<-ncol(newTib[[ getTibPtColPos()]][[rowIndex]]) pts<-newTib[[getTibPtColPos()]] #!!!! NOT USED????? ptDefs$tib[[selection]]<-newTib tabId<-getTibTabId() @@ -60,7 +63,7 @@ observeEvent( #adjust position rowIndex<-min(rowIndex, nrow(newTib)) - matCol<-ncol(newTib[[rowIndex, getTibPtColPos()]]) + matCol<-ncol(newTib[[getTibPtColPos()]][[rowIndex]]) if(length(matCol)==0){matCol=0} updateAceExtDef(newPtDefs, sender=sender, selector=list( rowIndex=rowIndex, matCol=matCol ) ) } @@ -81,7 +84,7 @@ observeEvent( returnValue4ModuleRtFtr$tagMoveUp(),{ #adjust position rowIndex<-rowIndex-1 - matCol<-ncol(newTib[[rowIndex, getTibPtColPos()]]) + matCol<-ncol(newTib[[ getTibPtColPos()]][[rowIndex]]) if(length(matCol)==0){matCol=0} updateAceExtDef(newPtDefs, sender=sender, selector=list( rowIndex=rowIndex, matCol=matCol ) ) } @@ -102,7 +105,7 @@ observeEvent( returnValue4ModuleRtFtr$tagMoveDown(),{ #adjust position rowIndex<-rowIndex+1 - matCol<-ncol(newTib[[rowIndex, getTibPtColPos()]]) + matCol<-ncol(newTib[[getTibPtColPos()]][[rowIndex]]) if(length(matCol)==0){matCol=0} updateAceExtDef(newPtDefs, sender=sender, selector=list( rowIndex=rowIndex, matCol=matCol ) ) } @@ -121,9 +124,9 @@ observeEvent( returnValue4ModuleRtFtr$removePt(), { #get row, col if(matCol>=1){ row<-getTibRow() - m<-matrix(ptDefs$tib[[selection]][[ row, getTibPtColPos() ]][,-matCol],2) + m<-matrix(ptDefs$tib[[selection]][[getTibPtColPos() ]][[row]] [,-matCol],2) #!!! probably need some checking here - ptDefs$tib[[selection]][[ row, getTibPtColPos() ]]<-m + ptDefs$tib[[selection]] [[getTibPtColPos() ]][[ row]]<-m matCol<-min(matCol, length(m)/2) newPtDefs<-ptDefs sender='points.deletePoint' @@ -149,13 +152,13 @@ observeEvent( returnValue4ModuleRtFtr$tagPt(), { updateRowPicker(session, "myTibRowCntrl", insertRow=rowIndex+1, selectRow=rowIndex+1) - m<-tib[[ rowIndex, getTibPtColPos() ]] + m<-tib[[getTibPtColPos() ]][[ rowIndex]] ptDefs$mats[selection]<-FALSE # no longer a matrix input! newTib<-tagTib(tib, getTibPtColPos(), rowIndex, matCol) rowIndex<-rowIndex+1 - matCol<-length(newTib[[rowIndex, getTibPtColPos()]])/2 + matCol<-length(newTib[[getTibPtColPos()]][[rowIndex]])/2 ptDefs$tib[[selection]]<-newTib tabId<-getTibTabId() @@ -218,4 +221,3 @@ observeEvent( returnValue4ModuleRtFtr$tagSetValue(),{ updateAceExtDef(newPtDefs, sender=sender ) }) - diff --git a/inst/App/rightPanel/header/moduleEdAsset.R b/inst/App/rightPanel/header/moduleEdAsset.R index 27c1abc0..f35b6612 100644 --- a/inst/App/rightPanel/header/moduleEdAsset.R +++ b/inst/App/rightPanel/header/moduleEdAsset.R @@ -26,11 +26,12 @@ moduleEdAsset<-function(input, output, session, ns <- session$ns #---assets output$dataSetUI<-renderUI({ - if( length(nameChoices() )>0){ + if( length(nameChoices() )>0 && length(name())>0 && name() %in% nameChoices() ){ butts<- nameChoices() - isolate(print(butts)) - radioGroupButtons(inputId=ns("name"), choices=butts, selected=name(), - justified=TRUE) + selected=name() + jqScrollBar(inputId=ns("name"), choices =butts, selected =selected) + # radioGroupButtons(inputId=ns("name"), choices=butts, selected=name(), + # justified=TRUE) } }) diff --git a/inst/App/rightPanel/header/moduleEdTib.R b/inst/App/rightPanel/header/moduleEdTib.R index 89c52afd..987db028 100644 --- a/inst/App/rightPanel/header/moduleEdTib.R +++ b/inst/App/rightPanel/header/moduleEdTib.R @@ -47,7 +47,7 @@ moduleEdTib<-function(input, output, session, name, nameChoices, getRowIndex, - getTibNRow, + getTibNRow, #extraneous??? matColIndex, matColIndexChoices, getMatColIndex, @@ -59,6 +59,7 @@ moduleEdTib<-function(input, output, session, getTibEditState, getTransformType, getWidgetChoices, + getChoiceSet4PageName, getWidget ){ ns <- session$ns @@ -75,25 +76,19 @@ moduleEdTib<-function(input, output, session, #------------ui ouput---------------------- - #---assets - # output$dataSetUI<-renderUI({ - # if(length(nameChoices())>0){ - # butts<- nameChoices() - # radioGroupButtons(inputId=ns("name"), choices=butts, selected=name(), - # justified=TRUE) - # } - # }) - - #---columns output$columnUI<-renderUI({ if( getTibEditState()==TRUE ){ - if(!is.null(getColumnName()) && !is.null(getColumnNameChoices())){ - radioGroupButtons(inputId=ns("columnRadio"), - choices=as.list(getColumnNameChoices()), - selected=getColumnName() , - justified=TRUE) + if(!is.null(getColumnName()) && !is.null(getColumnNameChoices())){ + + + jqScrollBar(inputId=ns("columnRadio"), + choices =getColumnNameChoices(), selected=getColumnName()) + # radioGroupButtons(inputId=ns("columnRadio"), + # choices=as.list(getColumnNameChoices()), + # selected=getColumnName() , + # justified=TRUE) } } }) @@ -101,17 +96,14 @@ moduleEdTib<-function(input, output, session, #---column values output$widgetChooserUI<-renderUI({ #widgetChoice if( getTibEditState()==TRUE ){ - # cat('--Entering ---widgetChooserUI----------\n') - # cat('--calling ---getWidgetChoices----------\n') choices<-getWidgetChoices() - # cat('--calling ---getWidget----------\n') + widget<-getWidget() - # cat('--returning from ---getWidget----------\n') - # cat("\nAfter getWidget value of getRowIndex=", format(getRowIndex()), "\n") + cs<-getChoiceSet4PageName() + if(!is.null(cs)){ + widget<-cs #selected widget + } if(length(choices )>0 && !is.null(widget)){ - #cat("tabId=",format(input$pages),"\n") - # cat("widgetChooserUI:: choices=c(",paste(choices,collapse=", "),")\n") - # cat('widget=',widget,"\n") div( "class"='ptR2', selectInput(ns("selectedWidget"), label=NULL, choices=choices, selected=widget, width="110px") @@ -122,70 +114,74 @@ moduleEdTib<-function(input, output, session, output$columnEntryUI<-renderUI({ if( getTibEditState()==TRUE ){ - # cat("\nEntering----------output$colEntryUI---------------\n") - # cat("\nInitial value of getRowIndex", format(getRowIndex()), "\n") - # cat('--calling ---getWidget2----------\n') widget<-getWidget() - # cat("widget=",format(widget),"\n") - # cat("getTibEntry()=",format(getTibEntry()),"\n") - # cat("getTibEntryChoices()=",format(getTibEntryChoices()),"\n") + cs<-getChoiceSet4PageName() if(!is.null(widget) && !is.null(getTibEntry()) && !is.null(getTibEntryChoices())){ selected<-getTibEntry() - # cat("length(selected)= ", length(selected), "\n") - if(length(selected)>1 ){ - selected<-paste("c(", paste(format(selected), collapse="," ),')') - } - # cat("length(selected)= ", length(selected), "\n") - # cat("(selected)= ", format(selected), "\n") + # log.val(selected) choices<-getTibEntryChoices() - choices<-lapply(choices, function(val){ - if(length(val)>1){ - val<-paste('c(', paste(format(val), collapse="," ),')') - } - val - }) - - choices<-sort(unique(unlist( choices ))) - #getTibEntryChoices() - #) - #)) - # cat('inside moduleEdTib::output$colEntryUI if widget==...\n') - if(widget=='radio'){ - # cat('xxx widget=', format(widget),"\n") - radioGroupButtons(inputId=ns("entryRadio"), - choices=choices, - selected=selected, - justified=TRUE - ) - } else if (widget=='picker'){ - # cat('xxx widget=', format(widget),"\n") - div( "class"="ptR2", width='800px', - selectizeInput(ns("entryValue"), label=NULL, - choices=choices, selected=selected, - options = list(create = TRUE, allowEmptyOption=FALSE, maxItems=1, width='200px') - ) - ) - } else if(widget=='colourable') { - # cat('xxx widget=', format(widget),"\n") - colourInput( - ns("entryColour"), label=NULL, value=selected - ) - } else if(widget=='numeric'){ - # cat('xxx widget=', format(widget),"\n") - numericInput( - ns('entryNumeric'), label = NULL, min=1, max = 100, value = as.numeric(selected) - ) - } else if(widget=='slider'){ - # cat('xxx widget=', format(widget),"\n") + if(widget=='slider'){ sliderInput( - inputId=ns("entrySlider"),label = NULL, min=1,max = 100, value = as.numeric(selected) - ) - } else if(widget=='knob'){ - # cat('xxx widget=', format(widget),"\n") - div(knobInput( - ns('entryKnob'), label = NULL, min=1, max = 100, value = as.numeric(selected), width=100, height=100 - )) - } + inputId=ns("entrySlider"),label = NULL, min=0,max = 100, value = as.numeric(selected) + ) + } else { + if(length(selected)>1 ){ + selected<-paste("c(", paste(format(selected), collapse="," ),')') + } + choices<-lapply(choices, function(val){ + if(length(val)>1){ + val<-paste('c(', paste(format(val), collapse="," ),')') + } + val + }) + choices<-sort(unique(unlist( choices ))) + if(!is.null(cs)){ + # cat('xxx widget=', format(widget),"\n") + # radioGroupButtons(inputId=ns("entryRadio"), + # choices=choices, + # selected=selected, + # justified=TRUE + # ) + jqScrollBar(inputId=ns("entryRadio"), + choices =choices, selected=selected) + + } else if(widget=='radio'){ + jqScrollBar(inputId=ns("entryRadio"), + choices =choices, selected=selected) + + } else if (widget=='picker'){ + # cat('xxx widget=', format(widget),"\n") + div( "class"="ptR2", width='800px', + selectizeInput(ns("entryValue"), label=NULL, + choices=choices, selected=selected, + options = list(create = TRUE, allowEmptyOption=FALSE, maxItems=1, width='200px') + ) + ) + } else if(widget=='colourable') { + # cat('xxx widget=', format(widget),"\n") + colourInput( + ns("entryColour"), label=NULL, value=selected + ) + } else if(widget=='numeric'){ + # cat('xxx widget=', format(widget),"\n") + numericInput( + ns('entryNumeric'), label = NULL, min=1, max = 100, value = as.numeric(selected) + ) + } else if(widget=='knob'){ + # cat('xxx widget=', format(widget),"\n") + # cat('value is ',selected, '\n') + div(knobInput( + ns('entryKnob'), label = NULL, min=1, max = 100, value = as.numeric(selected), width=100, height=100 + )) + } else if(widget=='immutable'){ + radioGroupButtons(inputId=ns("entryMutable"), + choices=selected, + selected=selected, + justified=TRUE + ) + } + } + # else if( widget=='spectrum'){ # spectrumInput( # inputId = ns("entrySpectrum"), @@ -204,53 +200,23 @@ moduleEdTib<-function(input, output, session, } }) - # output$matColIndexUI<-renderUI({ - # selected<-getTibEntry() %AND% getMatColMax() %AND% getMatColIndex() - # if(!is.null(selected) && getTibEntry()=='point'){ - # matColIndex=getMatColIndex() - # matColMax=getMatColMax() - # matColMin=ifelse(matColMax==0, 0, 1) - # numericInput(ns("matColIndex"), label="Mat Col", value= matColIndex, - # min=matColMin, max=matColMax, step=1, - # width= '80px' - # ) - # } - # }) - # + #---asset name--- observeEvent(c( name(), nameChoices() ), { #update the name if( !is.null(name()) && name()==transformTag ){ - # cat('transformPanelContainer show \n') showElement('transformPanelContainer') } else { - # cat('transformPanelContainer hide \n') hideElement('transformPanelContainer') } - # toggleElement( - # id='transformPanelContainer' , - # condition=(!is.null(name()) && name()==transformTag) - # ) - - # updateRadioGroupButtons(session, inputId=ns("name" ), - # choices=nameChoices(), selected=name() - # ) - - # cat('moduleEdTib observer:: name()=', format(name()),"\n") - + if(length(nameChoices())>0 && !is.null(name()) && nchar(name())>0 && !(name() %in% c( transformTag, RPanelTag, errorPanelTag, svgPanelTag)) ){ - # cat('headEdTib show\n') showElement('headEdTib') } else { - # cat('headEdTib hide\n') hideElement('headEdTib') hideElement(ns('headEdTib')) } - # toggleElement( - # id='headEdTib' , - # condition=!(name() %in% c( transformTag, RPanelTag, errorPanelTag, svgPanelTag)) - # ) - # cat('byre\n') + }) diff --git a/inst/App/rightPanel/header/serverEdAsset.R b/inst/App/rightPanel/header/serverEdAsset.R index abc277c8..11e0fbe6 100644 --- a/inst/App/rightPanel/header/serverEdAsset.R +++ b/inst/App/rightPanel/header/serverEdAsset.R @@ -27,7 +27,7 @@ observeEvent(returnValue4ModuleEdAsset$name(),{ } } } -,ignoreInit = TRUE) +,ignoreInit = FALSE) observeEvent( returnValue4ModuleEdAsset$newAsset(),{ showModal( addNewAssetModal() ) diff --git a/inst/App/rightPanel/header/serverEdTib.R b/inst/App/rightPanel/header/serverEdTib.R index d39ddeba..35f8c99a 100644 --- a/inst/App/rightPanel/header/serverEdTib.R +++ b/inst/App/rightPanel/header/serverEdTib.R @@ -30,6 +30,18 @@ returnValue4ModuleEdTib<-callModule( getTransformType=getTransformType, getTibEditState=getTibEditState, getWidgetChoices=getWidgetChoices, + getChoiceSet4PageName=reactive({ + if( getTibEditState()==TRUE ){ + widget<-getWidget() + if(!is.null(widget) && widget %in% names(aux$colChoiceSet)){ + return(widget) + } else { + return(NULL) + } + } else { + NULL + } + }), getWidget=getWidget #reactive({ if( getTibEditState()==TRUE ){ getHandlerValue() } else { NULL } }) ) @@ -45,14 +57,13 @@ getSafeSelection<-function(selection, choices){ #anybody using this??? } observeEvent(returnValue4ModuleEdTib$selectedWidget(), { - if( getTibEditState()==TRUE && !is.null( returnValue4ModuleEdTib$selectedWidget() )){ + if( getTibEditState()==TRUE && length( returnValue4ModuleEdTib$selectedWidget() )>0 ){ log.fin(returnValue4ModuleEdTib$selectedWidget()) selectedWidget<-returnValue4ModuleEdTib$selectedWidget() - log.val(selectedWidget) updateWidgetChoicesRow( selectedWidget=returnValue4ModuleEdTib$selectedWidget()) log.fout(returnValue4ModuleEdTib$selectedWidget()) } -}) +}, ignoreNULL = TRUE) observeEvent(returnValue4ModuleEdTib$transformType(),{ if( getPlotState()==transformTag){ @@ -92,23 +103,29 @@ observeEvent(returnValue4ModuleEdTib$entryValue(),{ if( getTibEditState()==TRUE ){ log.fin(returnValue4ModuleEdTib$entryValue() ) entry<-returnValue4ModuleEdTib$entryValue() + # if(length(entry)==0 || is.na(entry) ){ return(NULL) } - if(identical(getColumnType(),'point')){ entry<-which(entry==c('point','matrix')) if(length(entry)){ updateSelected(selIndex =entry) } - } else { - if(isNumericString(entry)){ - entry<-as.numeric(entry) - } else if (getColumnType() %in% + return(NULL) + } + # format entry according to columnType + if (identical(getColumnType(),'integer')){ + entry=as.integer(entry) + } else if (identical(getColumnType(),'numeric')){ + entry=as.numeric(entry) + } else if (identical(getColumnType(),'logical')){ + entry=as.logical(entry) + } else if (length(entry)==1 && getColumnType() %in% c("character.list", "character.list.2", "character.list.vec", "numeric.list", "numeric.list.2", "integer.list.2", "numeric.list.vec", "integer.list.vec") - ){ + ){ bad<-TRUE tryCatch({ entry<-eval(parse(text=entry)) #TODO!!!!!!!!!!!!! Better Error check??? @@ -118,28 +135,27 @@ observeEvent(returnValue4ModuleEdTib$entryValue(),{ triggerRefresh('cmd.commit') # this works but move to the last row. return(NULL) #TODO !!!! force reset dropdown value in modulueEdTib (refresh or commit?) } - } - name<-getAssetName() - newPtDefs<-getPtDefs() - columnName<-getTibColumnName() - rowIndex<-getTibRow() - good<-all(!sapply(list(name, newPtDefs, columnName, rowIndex), is.null)) - stopifnot(good) - tib<-newPtDefs$tib[[name]] - stopifnot( - 00){ + 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', - awesomeRadio('modalColTreatAs', 'Initialize Column Values as ', - choices = list( - ' a character string'='string','a single number'='number','a vector or list'='expression', - 'a matrix of points'='points' , 'the result of a preprocessing script'='script' - ) , - inline = TRUE + div( class='ptR2',id='modalColTreatAsDiv', + awesomeRadio('modalColTreatAs', 'Initialize Column Values as ', + choices = choices , + inline = TRUE, + selected=treatAsSelect ) ), - textInput("modalAttrValue", "Enter an entry value for the new column"), + div( + textInput("modalAttrValue", "Enter an entry value for the new column" ) + ), + # pick from preproc list if(length(ppscriptChoices)>0){ - div( class='ptR2', - awesomeRadio('modalColPreProcScript', 'Set entry values using the script:', + div( class='ptR2', #awesomeRadio + pickerInput('modalColPreProcScript', 'Set entry values using the script:', choices = ppscriptChoices, - inline = TRUE + 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;")) @@ -40,57 +74,120 @@ addNewColModal <- function(errMssg=NULL) { ) } +is.Non.Blank.Name<-reactiveVal(FALSE) +is.Non.Blank.Value<-reactiveVal(FALSE) -observeEvent(input$modalColTreatAs,{ - if(input$modalColTreatAs=='points'){ - hideElement('modalAttrValue') - hideElement('modalColPreProcScript') - } else if (input$modalColTreatAs=='script') { - hideElement('modalAttrValue') - showElement('modalColPreProcScript') +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 { - showElement('modalAttrValue') + 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)) - # parse(text=txt) rtv<-FALSE }, error = function(e) {}) rtv } - # browser() 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") ) + 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!") ) + showModal(addNewColModal( errMssg="Invalid Column Name: this name is already taken!", treatAsSelect=treatAs) ) } else if( - (!(treatAs %in% c('script', 'points' ))) && + (!(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") ) + 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") ) + showModal(addNewColModal( errMssg="Unable to evaluate expression", treatAsSelect=treatAs) ) } else { # checks passed #add name to tib - cat('treatAs=', format(treatAs),'\n') - cat('newVal=', format(newVal),'\n') newPtDefs<-getPtDefs() newColName<-input$modalAttrName - # browser() if(treatAs=='script'){ # apply script sequentially to newPtDefs # extract onNewRowScript script_Name<-input$modalColPreProcScript @@ -103,9 +200,7 @@ observeEvent(input$commitNewCol, { #One strategy tryCatch({ # 1. newPtDefs<-getPtDefs() - #newPtDefs<-getPtDefs() - #browser() - + # 2. tibs<-newPtDefs$tib # 3. @@ -132,37 +227,54 @@ observeEvent(input$commitNewCol, { keys=list(altKey=FALSE, shiftKey=FALSE, ctrlKey=FALSE, metaKey=FALSE, keycode=NULL) ) for(rowIndex in 1:nrow(tib)){ - #browser() 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' - #browser() - #updateAceExtDef(newPtDefs, sender=sender, selector=list( name=newColName ) ) + #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) + e<-c('preproErr',e$message) err<-paste(unlist(e), collapse="\n", sep="\n") - alert(err) + shinyalert("preproc new column Error",err, type="error") # may want to put this in a scrollable modal }) } else { #not scripting - # browser() + 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 ) ) diff --git a/inst/App/rightPanel/menu/serverPlotBar.R b/inst/App/rightPanel/menu/serverPlotBar.R index e5e476cc..caf75be8 100644 --- a/inst/App/rightPanel/menu/serverPlotBar.R +++ b/inst/App/rightPanel/menu/serverPlotBar.R @@ -7,15 +7,15 @@ observeEvent(input$plotNavBar, { return(NULL) } - if(cmd == 'cmdShowGrid'){ - renameDMDM(session, "plotNavBar", "cmdShowGrid", "Hide Grid", newValue="cmdHideGrid") - setSvgGrid(input$pages, show=TRUE) - } - - if(cmd == 'cmdHideGrid'){ - renameDMDM(session, "plotNavBar", "cmdHideGrid", "Show Grid",newValue="cmdShowGrid") - setSvgGrid(input$pages, show=FALSE) - } + # if(cmd == 'cmdShowGrid'){ + # renameDMDM(session, "plotNavBar", "cmdShowGrid", "Hide Grid", newValue="cmdHideGrid") + # setSvgGrid(input$pages, show=TRUE) + # } + # + # if(cmd == 'cmdHideGrid'){ + # renameDMDM(session, "plotNavBar", "cmdHideGrid", "Show Grid",newValue="cmdShowGrid") + # setSvgGrid(input$pages, show=FALSE) + # } if(cmd == 'cmdAdjustGridSpacing'){ spacingChoices<-c(.01, .05, .1, .5 ,1, 5,50,100,500) @@ -45,24 +45,24 @@ observeEvent(input$plotNavBar, { setBackDrop(hide=FALSE) } - if(cmd == 'cmdShowPointsNoLabels'){ - disableDMDM(session, menuBarId="plotNavBar", entry="cmdShowPointsNoLabels") - enableDMDM(session, menuBarId="plotNavBar", entry="cmdShowPointLabels") - enableDMDM(session, menuBarId="plotNavBar", entry="cmdHidePoints") - setDisplayOption(ptMode='Normal') - } - - if(cmd == 'cmdShowPointLabels'){ - enableDMDM(session, menuBarId="plotNavBar", entry="cmdShowPointsNoLabels") - disableDMDM(session, menuBarId="plotNavBar", entry="cmdShowPointLabels") - enableDMDM(session, menuBarId="plotNavBar", entry="cmdHidePoints") - setDisplayOption(ptMode='Labeled') - } + # if(cmd == 'cmdShowPointsNoLabels'){ + # disableDMDM(session, menuBarId="plotNavBar", entry="cmdShowPointsNoLabels") + # enableDMDM(session, menuBarId="plotNavBar", entry="cmdShowPointLabels") + # enableDMDM(session, menuBarId="plotNavBar", entry="cmdHidePoints") + # setDisplayOption(ptMode='Normal') + # } + # + # if(cmd == 'cmdShowPointLabels'){ + # enableDMDM(session, menuBarId="plotNavBar", entry="cmdShowPointsNoLabels") + # disableDMDM(session, menuBarId="plotNavBar", entry="cmdShowPointLabels") + # enableDMDM(session, menuBarId="plotNavBar", entry="cmdHidePoints") + # setDisplayOption(ptMode='Labeled') + # } if(cmd == 'cmdNewColumn'){ showModal( addNewColModal() ) } - + # -----PP if(cmd == 'cmdNewPP'){ # disable unless ... # columnName<-getTibColumnName() type='points' @@ -77,11 +77,7 @@ observeEvent(input$plotNavBar, { cmdPreProcPtsImport() dirtyDMDM(session, "plotNavBar") } - - # if(cmd=="cmdRemovePP"){ #-----save - # cmdPreProcPtsRemove('points') - # dirtyDMDM(session, "plotNavBar") - # } + # -----AP if(cmd == 'cmdNewAP'){ # disable unless ... log.fin(cmd == 'cmdNewAP' ) @@ -104,6 +100,29 @@ observeEvent(input$plotNavBar, { cmdPreProcAtsRemove('attrs') dirtyDMDM(session, "plotNavBar") } + # ----CC + if(cmd == 'cmdNewColumnChoices'){ # disable unless ... + log.fin(cmd == 'cmdNewColumnChoices' ) + type='attrs' + labels<-preprocChoices[[type]] + preprocScripts = fileTemplates[paste0(labels,'Template.R')] + names(preprocScripts)<-labels + cmdCustColumnEdit( custColumnName='') + dirtyDMDM(session, "plotNavBar") + log.fout(cmd == 'cmdNewAP') + dirtyDMDM(session, "plotNavBar") + } + + if(cmd == 'cmdImportColumnChoices'){ # disable unless ... + cmdChoiceSetImport() + dirtyDMDM(session, "plotNavBar") + } + + # if(cmd=="cmdRemoveAP"){ #-----save + # cmdPreProcAtsRemove('attrs') + # dirtyDMDM(session, "plotNavBar") + # } + if(!is.null(cmd)){ dirtyDMDM(session, "plotNavBar") @@ -130,11 +149,40 @@ observeEvent(input$plotNavBar, { modalPreProcEditor( preprocScripts, preprocName, type=type ) ) } - + if( grepl( '^editChoiceSet-', cmd)){ + choiceSetName<-sub("^editChoiceSet-","",cmd) + choiceSet=aux$colChoiceSet[[choiceSetName]] + value=paste(choiceSet, collapse="\n") + showModal( + modalCustColumnEditor(custColumnName=choiceSetName, value=value) + ) + } }) +observeEvent(input$cmdLabelPoints,{ + checked<-input$cmdLabelPoints + setDisplayOption(labelMode=checked) +}, ignoreNULL=TRUE) + +observeEvent(input$cmdInsertEnabled,{ + checked<-input$cmdInsertEnabled + setDisplayOption(insertMode=checked) +}, ignoreNULL=TRUE) + + +observeEvent(input$cmdRestrictRows,{ + checked<-input$cmdRestrictRows + setDisplayOption(restrictMode=checked) +}, ignoreNULL=TRUE) + +observeEvent(input$cmdShowGrid,{ + checked<-input$cmdShowGrid + setSvgGrid(input$pages, show=checked) +}, ignoreNULL=TRUE) + + diff --git a/inst/App/rightPanel/mid/moduleSVGR.R b/inst/App/rightPanel/mid/moduleSVGR.R index d153d978..5dce8f2c 100644 --- a/inst/App/rightPanel/mid/moduleSVGR.R +++ b/inst/App/rightPanel/mid/moduleSVGR.R @@ -22,12 +22,14 @@ svgToolsScript<-function(type){ showPts.compound, # =showsvgRPoints.pts2 ptrDisplayScript, # =js.scripts[[ "Points"]] useKeyMouseScript, # - getSVGWH, + # getSVGWH, #not used here??? getSvgGrid, getBackDrop, - getCode, + getCode, + getEnvList, getErrorMssg, - getTibNRow, # doesnot appear + # getTibNRow, # doesnot appear + getParMode, getDirPath ){ ns <- session$ns @@ -55,13 +57,15 @@ svgToolsScript<-function(type){ xy=scaleFactor*c(x,0)+c(5,5), x, text.anchor="start", alignment.baseline="hanging" , - transform=paste0('scale(',1/scaleFactor ,')') + transform=paste0('scale(',1/scaleFactor ,')'), + class="unselectable" ) ), lapply(ys, function(y)text(font.size=10, xy=scaleFactor*c(0,y)+c(5,-5), y, text.anchor="start", alignment.baseline="baseline", + class="unselectable", transform=paste0('scale(',1/scaleFactor ,')') )) ) } @@ -75,7 +79,7 @@ svgToolsScript<-function(type){ output$svghtml <- renderUI({ # renderUI is probably not the most efficient approach!!! - WH<-getSVGWH() + #WH<-getSVGWH() # not used here??? codeTxt<-getCode() if(is.null(getSvgGrid())){return(NULL)} @@ -96,59 +100,101 @@ svgToolsScript<-function(type){ wd<-paste0('\nsetwd("',dpath,'")\n\n') parsedCode<-parse(text=paste0(wd,codeTxt)) - svg<-eval(parsedCode, new.env() ) - w<-svg$root$getAttr('width') - h<-svg$root$getAttr('height') - rtv$WH<-c(w,h) - vbWH<-svg$root$getAttr('viewBox') - vbWH<-str_split(vbWH,',') - vbWH<-unlist(vbWH)[3:4] - vbScaleFactor<-1 - gWH<-c(w,h) - tryCatch({ - if(length(vbWH)==2 ){ - vbWH<-as.numeric(vbWH) - if(min(vbWH)>0){ - vbScaleFactor<-mean(rtv$WH/vbWH) - gWH<-vbWH - } else { - vbScaleFactor<-1 - } - } - }, error=function(e){ - vbScaleFactor<-1 - }) + parentMode<-getParMode() + env3<-getEnvList() + if(identical(parentMode, 'dnippets')){ + env3<-c(env3, list(WH=c(48,32))) + } + svg<-eval(parsedCode, env3 ) + + # cat('parentMode= ') + # cat(format(parentMode)) svg$root$setAttr('id',svgID) - if(getSvgGrid()$show==TRUE){ - dxy<-c( getSvgGrid()$dx, getSvgGrid()$dy) + if(identical(parentMode, 'dnippets')){ + svg$root$setAttr('width',480) + svg$root$setAttr('height',320) + svg$root$setAttr('viewBox','0 0 48 32') + svg$root$setAttr('stroke','#00FFFF') + svg$root$setAttr('fill','#00FFFF') + rtv$WH<-c(480,320) + vbScaleFactor<-10 + if(getSvgGrid()$show==TRUE){ + dxy=c(4,4) + svg$root$prependNode( graphPaper2( wh=c(48,32), dxy=dxy, labels=TRUE, scaleFactor= vbScaleFactor) ) + } + svg$root$prependChildren( + svgR:::use(filter=svgR:::filter( filterUnits='userSpaceOnUse', svgR:::feFlood(flood.color='black') ) ) + ) - #svg$root$prependNode(svgR:::graphPaper( wh=c(w,h), dxy=dxy, labels=TRUE )) #need to replace with vbScaleFactor-scalable version - #svg$root$prependNode( graphPaper2( wh=c(w,h), dxy=dxy, labels=TRUE, scaleFactor= vbScaleFactor)) - svg$root$prependNode( graphPaper2( wh=gWH, dxy=dxy, labels=TRUE, scaleFactor= vbScaleFactor)) - } - if(getBackDrop()$checked==FALSE){ + } else { + # record width, height + w<-svg$root$getAttr('width') + h<-svg$root$getAttr('height') + rtv$WH<-c(w,h) + + # if viewBox, calculate vbScaleFactor, else vbScaleFactor=1 + vbWH<-svg$root$getAttr('viewBox') + vbWH<-str_split(vbWH,',') + vbWH<-unlist(vbWH)[3:4] + vbScaleFactor<-1 + gWH<-c(w,h) + tryCatch({ + if(length(vbWH)==2 ){ + vbWH<-as.numeric(vbWH) + if(min(vbWH)>0){ + vbScaleFactor<-mean(rtv$WH/vbWH) + gWH<-vbWH + } else { + vbScaleFactor<-1 + } + } + }, + error=function(e){ + vbScaleFactor<-1 + }) + if(getSvgGrid()$show==TRUE){ + dxy<-c( getSvgGrid()$dx, getSvgGrid()$dy) + + #svg$root$prependNode(svgR:::graphPaper( wh=c(w,h), dxy=dxy, labels=TRUE )) #need to replace with vbScaleFactor-scalable version + #svg$root$prependNode( graphPaper2( wh=c(w,h), dxy=dxy, labels=TRUE, scaleFactor= vbScaleFactor)) + svg$root$prependNode( graphPaper2( wh=gWH, dxy=dxy, labels=TRUE, scaleFactor= vbScaleFactor) ) + } + + if(getBackDrop()$checked==FALSE){ #solid svg$root$prependChildren( svgR:::use(filter=svgR:::filter(xy=c(0,0), wh=c(w,h), filterUnits="userSpaceOnUse", svgR:::feFlood(flood.color=getBackDrop()$color))) ) - } else { - wh2=c(20,20)/vbScaleFactor - wh1=c(10,10)/vbScaleFactor - svg$root$prependChildren( - svgR:::rect(xy=c(0,0), wh=c(w,h), - fill=svgR:::pattern( xy=c(0,0), wh=wh2, patternUnits="userSpaceOnUse", - svgR:::g( - svgR:::rect(xy=c(0,0), wh=wh1, fill=getBackDrop()$color), - svgR:::rect(xy=wh1, wh=wh1, fill=getBackDrop()$color) - ) - ) + } else { # checkered + wh2=c(20,20)/vbScaleFactor + wh1=c(10,10)/vbScaleFactor + svg$root$prependChildren( + svgR:::rect(xy=c(0,0), wh=c(w,h), + fill=svgR:::pattern( xy=c(0,0), wh=wh2, patternUnits="userSpaceOnUse", + svgR:::g( + svgR:::rect(xy=c(0,0), wh=wh1, fill=getBackDrop()$color), + svgR:::rect(xy=wh1, wh=wh1, fill=getBackDrop()$color) + ) + ) ) ) + } + } + + + + # svg$root$setAttr('id',svgID) + + svg$root$prependNode(svgR:::script(ptrDisplyScriptTxt)) svg$root$prependNode( svgR:::style(".draggable {','cursor: move;','}")) if(!is.null(showPts.compound()) ){ - temp<-svgR(showPts.compound()(vbScaleFactor))$root$xmlChildren() + labelColor='black' + if(!is.null(parentMode) || getBackDrop()$color %in% c('#000000','#FF0000','#0000FF','#333333' )){ + labelColor="white" + } + temp<-svgR(showPts.compound()(vbScaleFactor, labelColor))$root$xmlChildren() svg$root$appendChildren(temp) } if(useKeyMouseScript){ @@ -156,10 +202,7 @@ svgToolsScript<-function(type){ keyMouseScript=paste0('onKeyMouseDown(evt, "', svgID, '")') svg$root$addAttributes(list(onmousedown=keyMouseScript)) } - - - - as.character(svg)->svgOut + as.character(svg)->svgOut res<-HTML(svgOut) rtv$status<-list( state="PASS", diff --git a/inst/App/rightPanel/mid/serverPlotBarPoints.R b/inst/App/rightPanel/mid/serverPlotBarPoints.R index e906cb7f..b445bbb8 100755 --- a/inst/App/rightPanel/mid/serverPlotBarPoints.R +++ b/inst/App/rightPanel/mid/serverPlotBarPoints.R @@ -9,10 +9,21 @@ pts=NULL, rowIndex=NULL, matColIndex=NULL, - ptDisplayMode="Normal", - vbScaleFactor + displayOptions=NULL, + vbScaleFactor, + labelColor="black" ){ - if(is.null(ptDisplayMode) || ptDisplayMode=="Hidden"){ return(NULL) } + + + if(is.null(displayOptions)){ + return(NULL) + } + + displayOpt<-displayOptions + if(is.null(displayOpt)||is.null(displayOpt$labelMode) || is.null(displayOpt$restrictMode)){ return(NULL)} + + + # if(is.null(ptDisplayMode) || ptDisplayMode=="Hidden"){ return(NULL) } onMouseDownTxt='ptRPlotter_ptR_SVG_Point.selectPoint(evt)' if(is.null(pts) ){ return(NULL) } if(length(unlist(pts))<2){ return(NULL)} @@ -23,16 +34,19 @@ opacity[rowIndex]<-1 #form list of all point renderings + if(displayOptions$restrictMode==TRUE){ + rows=rowIndex + } else { + rows=1:length(pts) + } g( - lapply(seq(length(pts)), function(i){ + lapply(rows, function(i){ m<-pts[[i]] if(length(m)==0){ # or !is(m,'matrix') NULL } else { lapply(seq(ncol(m)), function(j){ #j is the matCol index - id<-paste("pd",ptName,i,j,sep="-") - pt<-m[,j] color=colorScheme['default'] @@ -54,9 +68,9 @@ onmousedown=onMouseDownTxt ) }, - if(ptDisplayMode=="Labeled"){ + if(displayOpt$labelMode==TRUE){ text(paste0(i,",",j), xy=c(10,-10), - stroke='black', font.size=12, opacity=1, + stroke=labelColor, font.size=12, opacity=1, transform=list(scale=1/vbScaleFactor,translate=vbScaleFactor*pt)) } else { NULL @@ -81,7 +95,7 @@ newPtLayer %--> dripplets2Rmd\n') src<-dripplets2Rmd(src) - # cat(src) - # cat('<--< dripplets2Rmd\n') } - # knit2html(text = src, fragment.only = FALSE, quiet = TRUE) div( style='background-color: #FFFFFF;', - HTML(knit2html(text =src , fragment.only = TRUE, quiet = TRUE)) + HTML( + knit2html(text = src, fragment.only = TRUE, quiet = TRUE, envir=getEnvList() ) + # knit2html(text =src , fragment.only = TRUE, quiet = TRUE + ) ) } else { HTML('') @@ -36,3 +33,37 @@ rmdModuleList<-callModule( getPanelName=getRightMidPanel, getCode=getCode4Rendering ) + + +extractCodeBlocksFromRmd<-function(txt){ + + lines<-unlist(str_split(txt, '\n')) + # print(lines) + pos<-grep('^```', lines) + np<-length(pos) + # cat('np=',format(np),"\n") + blocks<-NULL + if(np>=2){ + if(np%%2==1){ + np=np-1 + } + pow<-pos[1:np] + pos<-matrix(pow,2) + # print(pos) + i<-pos[1,] + ll<-lines[i] + + cols<-grep('^```\\s*\\{\\s*r[,[:space:]]',lines[i]) + # cat('cols=',format(cols),'\n') + pos<-pos[,cols] + if(length(cols)>0){ + pos<-matrix(pos,2) + # print(pos) + blocks<-apply(pos,2, function(x){ + paste0(lines[(x[1]+1):(x[2]-1)], collapse="\n") + }) + # print(blocks) + } + } + blocks +} \ No newline at end of file diff --git a/inst/App/rightPanel/mid/serverRowIndexCtrl.R b/inst/App/rightPanel/mid/serverRowIndexCtrl.R index c38a4bf7..9c724c38 100644 --- a/inst/App/rightPanel/mid/serverRowIndexCtrl.R +++ b/inst/App/rightPanel/mid/serverRowIndexCtrl.R @@ -23,6 +23,7 @@ rowGroupsDB.addRow<-function(pageId, aname, cname, row_index ){ # so, the control cannot determine what was the initial trigger observeEvent( getTibRow(), { + # log.fin( getTibRow()) rowIndex<-input$myTibRowCntrl$selected if(!is.null(getTibRow()) && identical(rowIndex,getTibRow()) && @@ -32,6 +33,7 @@ observeEvent( getTibRow(), { return(NULL) } updateRowPicker(session, "myTibRowCntrl",selectRow = getTibRow() ) + # log.fout( getTibRow()) }) @@ -44,6 +46,7 @@ observeEvent( getTibRow(), { # 5. user code change (USER COMMIT) # the number of rows is determined from ptDefs after ace update resetRowPickeR<-function(){ + # log.fin(resetRowPickeR) rowIndex<-input$myTibRowCntrl$selected if(!is.null(getTibRow()) && identical(rowIndex,getTibRow()) && @@ -61,6 +64,7 @@ resetRowPickeR<-function(){ # CLONE # SPLIT # DELETE + # log.fout(resetRowPickeR) } @@ -82,12 +86,12 @@ observeEvent( input$myTibRowCntrl$selected, { # else # cat('group is empty\n') # cat('bailing\n') - # log.fout(input$myTibRowCntrl$selected) + # log.fout(input$myTibRowCntrl$selected) return(NULL) #bail } rowIndex<-min(getTibNRow(),rowIndex) # compute matColIndex and update rowIndex, matColIndex - if(getColumnType()=='point'){ + if(identical(getColumnType(),'point')){ pts<-getTibPts() matColIndex<-length(pts[[rowIndex]])/2 updateSelected( matCol=matColIndex, rowIndex=rowIndex) @@ -100,19 +104,22 @@ observeEvent( input$myTibRowCntrl$selected, { updateSelected( rowIndex=rowIndex) } } - # log.fout(input$myTibRowCntrl$selected) + # log.fout(input$myTibRowCntrl$selected) } }) # rowPicker => the tib row order observeEvent( input$myTibRowCntrl$order,{ log.fin(input$myTibRowCntrl$order) - if( getTibEditState()==TRUE & !all(diff(input$myTibRowCntrl$order)==1)){ + if( getTibEditState()==TRUE & !all(diff(input$myTibRowCntrl$order)==1)){ ordering<-input$myTibRowCntrl$order log.val(ordering) name<-getAssetName() row<-getTibRow() columnName<-getTibColumnName() + if(is.null(columnName)){ + return(NULL) + } newPtDefs<-getPtDefs() tib<-newPtDefs$tib[[name]] tib<-tib[ordering,] @@ -131,8 +138,8 @@ observeEvent( input$myTibRowCntrl$order,{ # rowPicker => rowGroupsDB observeEvent( input$myTibRowCntrl$group,{ - if( getTibEditState()==TRUE ){ - # log.fin(input$myTibRowCntrl$group) + if( getTibEditState()==TRUE && !is.null(getTibColumnName())){ + log.fin(input$myTibRowCntrl$group) group<-input$myTibRowCntrl$group # if(length(group)>0) # log.val(format(paste(group,collapse=","))) @@ -149,70 +156,45 @@ observeEvent( input$myTibRowCntrl$group,{ rowGroupsDB(db) # cat('now rowGroupsDB=') # print(rowGroupsDB()) - # log.fout(input$myTibRowCntrl$group) + log.fout(input$myTibRowCntrl$group) } }) # new asset , reload rowCntrl from rowGroupsDB # selector$name + rowGroupsDB => rowPicker observeEvent(getAssetName(),{ #reload rowpicker + aname<-getAssetName() - if(!is.null(aname)){ + pageId<-getTibTabId() + count<-getTibNRow() + cname<-getTibColumnName() + if(!is.null(aname) && !is.null(pageId) && length(count)>0 && length(cname)>0 ){ # log.fin("reload rowpicker") - # log.val(aname) - # group<-input$myTibRowCntrl$group - # if(length(group)>0){ - # cat('groups=\n') - # log.val(format(paste(group,collapse=","))) - # } else { - # cat('group is empty\n') - # } - # print(rowGroupsDB()) pageId<-getTibTabId() count<-getTibNRow() - aname<-getAssetName() cname<-getTibColumnName() group<-filter(rowGroupsDB(), tabId==pageId, name==aname, colName==cname)$rows row<-getTibRow() - #browser() + if(length(group)>0 && !(row %in% group)){ row<-tail(group,1) updateSelected(rowIndex=row) } - #browser() - # cat('class of group is ',class(group),'\n') - # updateRowPicker(session, "myTibRowCntrl", - # count= count - # ) - # cat('************ (getAssetName count=count\n') - # print(rowGroupsDB()) - # cat('*********before**************\n') updateRowPicker(session, "myTibRowCntrl", count= count, selectRow = row, addToGroup=group ) - # cat('*********after**************\n') - # print(rowGroupsDB()) - # if(length(group)>0){ - # cat('groups=\n') - # log.val(format(paste(group,collapse=","))) - # } else { - # cat('group is empty\n') - # } - # log.fout("reload picker") + # log.fout("reload rowpicker") } }) observeEvent(getTibTabId(),{ # log.fin(getTibTabId()) - # cat('-----initializing rowGroupDB-----\n') - # count=getTibNRow() - # log.val(count) rowGroupsDB(initialRowGroupDB()) updateRowPicker(session, "myTibRowCntrl", selectRow=getTibRow(), diff --git a/inst/App/rightPanel/mid/serverSvgBackdrop.R b/inst/App/rightPanel/mid/serverSvgBackdrop.R index 0610e48e..d92219a9 100644 --- a/inst/App/rightPanel/mid/serverSvgBackdrop.R +++ b/inst/App/rightPanel/mid/serverSvgBackdrop.R @@ -72,4 +72,3 @@ getBackDrop<-reactive({ getPageBackDrop(input$pages) }) - diff --git a/inst/App/rightPanel/mid/serverSvgGrid.R b/inst/App/rightPanel/mid/serverSvgGrid.R index 024d56ad..5a12a268 100644 --- a/inst/App/rightPanel/mid/serverSvgGrid.R +++ b/inst/App/rightPanel/mid/serverSvgGrid.R @@ -85,11 +85,12 @@ observeEvent(input$pages,{ # cat(">---> input$pages 5\n") tb<-getSvgGrid() if(length(tb$show)>0){ - if(tb$show){ - renameDMDM(session, "plotNavBar", "cmdShowGrid", "Hide Grid", newValue="cmdHideGrid") - }else{ - renameDMDM(session, "plotNavBar", "cmdHideGrid", "Show Grid",newValue="cmdShowGrid") - } + updateCheckboxInput(session, "cmdShowGrid", value = tb$show) + # if(tb$show){ + # renameDMDM(session, "plotNavBar", "cmdShowGrid", "Hide Grid", newValue="cmdHideGrid") + # }else{ + # renameDMDM(session, "plotNavBar", "cmdHideGrid", "Show Grid",newValue="cmdShowGrid") + # } } # cat("<---< input$pages 5\n") }) diff --git a/inst/App/rightPanel/mouse/serverMouseCmdAddPt.R b/inst/App/rightPanel/mouse/serverMouseCmdAddPt.R index 5038514c..25b1dfc1 100644 --- a/inst/App/rightPanel/mouse/serverMouseCmdAddPt.R +++ b/inst/App/rightPanel/mouse/serverMouseCmdAddPt.R @@ -7,22 +7,24 @@ mouseCmdAddPt<-function(mssg){ replacementList<-list() ptDefs<-getPtDefs() updateRowPicker(session, "myTibRowCntrl", removeEntireGroup=TRUE) - # tibs<-getPtDefs()$tib - sender='PointsBar.mouse.add' + sender='PointsBar.mouse.add' + keycode=mssg$keycode newPt<-vec selection<-getAssetName() rowIndex<-getTibRow() matColIndx<-getTibMatCol() + if( length( getPointMax())>1){ stop('getPointMax is too big')} #should never happen - pts<-ptDefs[[ selection]][[rowIndex,getTibColPos()]] + if(!is.na(getPointMax()) && getTibMatColMax() >= getPointMax() ){ #need to split? #split + updateRowPicker(session, "myTibRowCntrl", insertRow=rowIndex+1, selectRow=rowIndex+1) tibs<-ptDefs$tib - tib<-tibs[[selection]] + tib<-tibs[[selection]] tib<-bind_rows(tib[1:rowIndex,], tib[rowIndex:nrow(tib),]) rowIndex<-rowIndex+1 tib[[getTibColumnName()]][[rowIndex]]<-matrix(0,2,0) @@ -31,7 +33,8 @@ mouseCmdAddPt<-function(mssg){ ptDefs$tib<-tibs # since we just added a new row we must check if we need to # modify (preproc) the values in that row - + + scripts<-getPreProcOnNewRowScripts( getTibTabId(), selection) if(length(scripts)>0){ newTibs<-tibs # backup tibs, @@ -53,16 +56,15 @@ mouseCmdAddPt<-function(mssg){ setAttrValue=setAttrValue, getAttrValue=getAttrValue, context=context, - keys=list(alt=mssg$altKey, shift=mssg$shiftKey, ctrl=mssg$ctrlKey, meta=mssg$metaKey) + keys=list(alt=mssg$altKey, shift=mssg$shiftKey, ctrl=mssg$ctrlKey, meta=mssg$metaKey, keycode=mssg$keycode) ) tibs<-eval(parse(text=txt), ppenv ) validateTibLists(getPtDefs()$tib, tibs) } # all cols done successfully ptDefs$tib<-tibs # success, reset ptDefs }, error=function(e){ - e<-c('preproErr',e) - err<-paste(unlist(e), collapse="\n", sep="\n") - alert(err) + err<-paste(e$message, collapse="\n", sep="\n") + shinyalert("preproc new point Error",err, type="error") }) } #end of scripts } # end of split @@ -73,6 +75,7 @@ mouseCmdAddPt<-function(mssg){ txt<-getPreProcScript()['onNewPt'] if( !is.null(txt) ){ #preproc pts tryCatch({ + getPoint<-function(){names(newPt)<-c('x','y'); newPt} context<-list( name=getAssetName(), @@ -83,8 +86,9 @@ mouseCmdAddPt<-function(mssg){ ) ppenv<-list( getPoint=getPoint, + insertPoint=insertPoint, context=context, - keys=list(alt=mssg$altKey, shift=mssg$shiftKey, ctrl=mssg$ctrlKey, meta=mssg$metaKey), + keys=list(alt=mssg$altKey, shift=mssg$shiftKey, ctrl=mssg$ctrlKey, meta=mssg$metaKey, keycode=mssg$keycode), WH=getSVGWH() ) tibs<-eval(parse(text=txt), ppenv ) @@ -94,9 +98,8 @@ mouseCmdAddPt<-function(mssg){ updateAceExtDef(newPtDefs, sender=sender, selector=list( rowIndex=rowIndex, matCol=matColIndx+1)) } },error=function(e){ - e<-c('preproErr',e) - err<-paste(unlist(e), collapse="\n", sep="\n") - alert(err) + err<-paste(e$message, collapse="\n", sep="\n") + shinyalert("preproc new point Error",err, type="error") }) } else { #no prepoc pts tib<-tibs[[selection]] diff --git a/inst/App/rightPanel/mouse/serverMouseCmdFindPoint.R b/inst/App/rightPanel/mouse/serverMouseCmdFindPoint.R index e7e6268c..6ea434d3 100644 --- a/inst/App/rightPanel/mouse/serverMouseCmdFindPoint.R +++ b/inst/App/rightPanel/mouse/serverMouseCmdFindPoint.R @@ -3,7 +3,7 @@ mouseCmdFindPoint<-function(mssg){ pt<- as.numeric(unlist(mssg$vec)) } - + # browser() fromColumnName<-getTibColumnName() fromCol<-getTib()[[fromColumnName]] fromColType<-extractColType( fromCol) @@ -51,8 +51,7 @@ mouseCmdFindPoint<-function(mssg){ } } - if( mssg$ctrlKey==TRUE){ #add row to rowGroupsDB - # browser() + if( mssg$shiftKey==TRUE){ #add row to rowGroupsDB if( getAssetName()==toName ){ if( getTibRow()==toRow){ updateRowPicker(session, "myTibRowCntrl", toggleGroup = toRow) diff --git a/inst/App/rightPanel/mouse/serverMouseCmdMoveMatrix.R b/inst/App/rightPanel/mouse/serverMouseCmdMoveMatrix.R index 281734a2..5385832a 100644 --- a/inst/App/rightPanel/mouse/serverMouseCmdMoveMatrix.R +++ b/inst/App/rightPanel/mouse/serverMouseCmdMoveMatrix.R @@ -4,6 +4,7 @@ mouseCmdMoveMatrix<-function(mssg){ vec<- as.numeric(unlist(mssg$vec)) } src<-getCode() + replacementList<-list() newPtDefs<-getPtDefs() tibs<-getPtDefs()$tib @@ -13,8 +14,8 @@ mouseCmdMoveMatrix<-function(mssg){ tmp<-unlist(str_split(id,"_")) row<-as.numeric(tail(tmp,1)) #this should be the same as selected row index selection<-getAssetName() - matColIndx<-ncol(newPtDefs$tib[[selection]][[ row, getTibPtColPos() ]]) - + matColIndx<-ncol(newPtDefs$tib[[selection]][[getTibPtColPos()]][[ row ]]) + # Todo: for inter tib move support # selection -> 1 or more selections # row (currently corresponding to single name) - sets of rows @@ -56,8 +57,7 @@ mouseCmdMoveMatrix<-function(mssg){ colName=getTibColumnName() ) pageId<-getTibTabId() - - if( mssg$ctrlKey==TRUE){ + if( mssg$shiftKey==TRUE){ if(getTibRow()!=row){ updateRowPicker(session, "myTibRowCntrl", addToGroup = row, selectRow = row ) } else { @@ -72,7 +72,6 @@ mouseCmdMoveMatrix<-function(mssg){ } else { updateRowPicker(session, "myTibRowCntrl", removeEntireGroup=TRUE) } - contextList<-pmap(cntx, function(name, rows, colName){ # to check that tib has names ctype<-extractColType(tibs[[name]][[colName]]) @@ -84,12 +83,13 @@ mouseCmdMoveMatrix<-function(mssg){ } }) contextList<-Filter(function(x){!is.null(x)}, contextList) - tryCatch({ matCol<-NULL getDxy<-function(){names(dxy)<-c('dx','dy'); dxy} ppenv<-list( - keys=list(alt=mssg$altKey, shift=mssg$shiftKey, ctrl=mssg$ctrlKey, meta=mssg$metaKey), + getDxy=getDxy, + moveMatrix=moveMatrix, + keys=list(alt=mssg$altKey, shift=mssg$shiftKey, ctrl=mssg$ctrlKey, meta=mssg$metaKey, keycode=mssg$keycode), WH=getSVGWH() ) for(ctx in contextList){ @@ -99,20 +99,20 @@ mouseCmdMoveMatrix<-function(mssg){ column_Name= names( tibs[[ctx$name]] )[ ctx$column ] )['onMoveMat'] if(is.null(txt)){ - m<-tibs[[ctx$name]][[ ctx$row, ctx$column ]] - tibs[[ctx$name]][[ ctx$row, ctx$column ]]<-m+dxy + m<-tibs[[ctx$name]][[ctx$column ]][[ctx$row ]] + tibs[[ctx$name]][[ctx$column ]][[ctx$row ]]<-m+dxy } else { context<-c(ctx, list(tibs=tibs)) - tibs<-eval(parse(text=txt), ppenv ) + tppenv<-c(ppenv,context) + tibs<-eval(parse(text=txt), tppenv ) validateTibLists(getPtDefs()$tib, tibs) } } - matCol<-ncol(tibs[[getAssetName()]][row, getTibPtColPos()] ) + matCol<-ncol(tibs[[getAssetName()]][[getTibPtColPos()]][[row]] ) newPtDefs$tib<-tibs - # cat('ContextList updateAceExtDef\n') updateAceExtDef(newPtDefs, sender=sender, selector=list( rowIndex=row, matCol=matCol)) }, error=function(e){ - e<-c('preproErr',unlist(e)) + e<-c('preproErr',e$message) err<-paste(unlist(e), collapse="\n", sep="\n") alert(err) }) diff --git a/inst/App/rightPanel/mouse/serverMouseCmdMovePt.R b/inst/App/rightPanel/mouse/serverMouseCmdMovePt.R index c8629034..f03ae05f 100644 --- a/inst/App/rightPanel/mouse/serverMouseCmdMovePt.R +++ b/inst/App/rightPanel/mouse/serverMouseCmdMovePt.R @@ -3,6 +3,7 @@ mouseCmdMovePt<- function(mssg){ vec<- as.numeric(unlist(mssg$vec)) } src<-getCode() + keycode=mssg$keycode replacementList<-list() ptDefs<-getPtDefs() updateRowPicker(session, "myTibRowCntrl", removeEntireGroup=TRUE) @@ -27,8 +28,11 @@ mouseCmdMovePt<- function(mssg){ ptIndex=matColIndx, tibs=getPtDefs()$tib ) - ppenv<-list( - keys=list(alt=mssg$altKey, shift=mssg$shiftKey, ctrl=mssg$ctrlKey, meta=mssg$metaKey), + ppenv<-list( + getPoint=getPoint, + movePoint=movePoint, + context=context, + keys=list(alt=mssg$altKey, shift=mssg$shiftKey, ctrl=mssg$ctrlKey, meta=mssg$metaKey, keycode=mssg$keycode), WH=getSVGWH() ) tibs<-eval(parse(text=txt), ppenv ) @@ -38,12 +42,12 @@ mouseCmdMovePt<- function(mssg){ updateAceExtDef(newPtDefs, sender=sender, selector=list( rowIndex=rowIndex, matCol=matColIndx)) } },error=function(e){ - e<-c('preproErr',unlist(e)) - err<-paste(unlist(e), collapse="\n", sep="\n") + e<-c('preproErr',e$message) + err<-paste(e$message, collapse="\n", sep="\n") alert(err) }) } else { - newPtDefs$tib[[selection]][[ rowIndex, getTibPtColPos() ]][,matColIndx]<-newPt + newPtDefs$tib[[selection]][[getTibPtColPos()]][[ rowIndex ]][,matColIndx]<-newPt if(!is.null(newPtDefs)){ #update only upon success updateAceExtDef(newPtDefs, sender=sender, selector=list( rowIndex=rowIndex, matCol=matColIndx)) } diff --git a/inst/App/rightPanel/mouse/serverMouseCmdValue.R b/inst/App/rightPanel/mouse/serverMouseCmdValue.R index 24cf63df..32ae0e75 100644 --- a/inst/App/rightPanel/mouse/serverMouseCmdValue.R +++ b/inst/App/rightPanel/mouse/serverMouseCmdValue.R @@ -1,4 +1,5 @@ mouseCmdValue<- function(mssg){ + #cat('mouseCmdVal\n') if(length(mssg$vec)>0){ vec<- as.numeric(unlist(mssg$vec)) } @@ -7,8 +8,20 @@ mouseCmdValue<- function(mssg){ ptDefs<-getPtDefs() tmp<-unlist(str_split(mssg$id,"_")) row<-as.numeric(tail(tmp,1)) - - if( mssg$ctrlKey==TRUE){ #add row to rowGroupsDB + mssg$char<-NULL + if (length(mssg$keycode)>0){ + kc<-mssg$keycode + if( (65<=kc && kc<=90 ) || (40<=kc && kc<=57)){ #process char or numeric only + if(mssg$shiftKey==FALSE && 65<=kc && kc<=90){ + kc=kc+32 + } + mode(kc)<-'raw' + kc<-rawToChar(kc) + mssg$char<-kc + } + } + + if( mssg$shiftKey==TRUE){ #add row to rowGroupsDB if(getTibRow()!=row){ updateRowPicker(session, "myTibRowCntrl", addToGroup = row, selectRow = row ) } else { diff --git a/inst/App/rightPanel/preProc/modalPreprocEditor.R b/inst/App/rightPanel/preProc/modalPreprocEditor.R index af042bf8..b011193e 100644 --- a/inst/App/rightPanel/preProc/modalPreprocEditor.R +++ b/inst/App/rightPanel/preProc/modalPreprocEditor.R @@ -54,7 +54,7 @@ modalPreProcEditor <- function( preprocScripts, preprocName, type='points' ) { observeEvent(input$modalPreprocName,{ preprocName<-input$modalPreprocName - if(length(preprocName)==0 || nchar(preprocName)<8){ + if(length(preprocName)==0 || nchar(preprocName)<6){ hideElement("modalPreprocEditorCommitOk") } else { showElement("modalPreprocEditorCommitOk") @@ -71,13 +71,15 @@ observeEvent( input$modalPreprocEditorCommitOk,{ cmds<-preprocChoices[[type]] aceIds<-paste0('preProcAce-', cmds) scripts<-lapply(aceIds, function(x){input[[x]]}) + names(scripts)<-cmds if(type=='points'){ filePath<-file.path(getPreProcPPAuxPath(), preprocName) } else { filePath<-file.path(getPreProcPAAuxPath(), preprocName) } - writeAuxPreprocPoints(filePath, scripts) + writeAuxPreprocList(filePath, scripts) + readAuxPreProcs() removeModal() diff --git a/inst/App/rightPanel/preProc/preProcSetAttr.R b/inst/App/rightPanel/preProc/preProcSetAttr.R index d03d69db..a8ae4099 100644 --- a/inst/App/rightPanel/preProc/preProcSetAttr.R +++ b/inst/App/rightPanel/preProc/preProcSetAttr.R @@ -11,7 +11,7 @@ setAttrValue<-function( value, context){ tib<-tibs[[ assetName ]] rowIndex<- context$row columnIndex<-context$column - tib[[rowIndex,columnIndex]]<-value + tib[[columnIndex]][[rowIndex]]<-value tibs[[ assetName ]]<-tib } return(tibs) diff --git a/inst/App/rightPanel/preProc/preprocTrySetAttrValue.R b/inst/App/rightPanel/preProc/preprocTrySetAttrValue.R index 82654f50..580e38cf 100644 --- a/inst/App/rightPanel/preProc/preprocTrySetAttrValue.R +++ b/inst/App/rightPanel/preProc/preprocTrySetAttrValue.R @@ -30,7 +30,7 @@ preprocTrySetAttrValue<-function( cmd.Row, ptDefs, rowIndex, selection, mssg=NUL appendLastRow=appendLastRow, appendAttrValues=appendAttrValues, context=context, - keys=list(alt=mssg$altKey, shift=mssg$shiftKey, ctrl=mssg$ctrlKey, meta=mssg$metaKey, keycode=mssg$keycode) + keys=list(alt=mssg$altKey, shift=mssg$shiftKey, ctrl=mssg$ctrlKey, meta=mssg$metaKey, keycode=mssg$keycode, char=mssg$char) ) tibs<-eval(parse(text=txt), ppenv ) validateTibLists(getPtDefs()$tib, tibs) @@ -38,9 +38,9 @@ preprocTrySetAttrValue<-function( cmd.Row, ptDefs, rowIndex, selection, mssg=NUL sender='applyTibEdit' updateAceExtDef(ptDefs, sender=sender, selector=list( name=context$name, rowIndex=context$row ) ) }, error=function(e){ - e<-c('preproErr',e) + e<-c('onChangeRow:',e$message) err<-paste(unlist(e), collapse="\n", sep="\n") - alert(err) + shinyalert("preproc value Errpr",err, type="error") }) log.fin(preprocTrySetAttrValue) } @@ -75,7 +75,8 @@ preprocTrySetAttrValueS<-function(scripts, ptDefs, rowIndex, selection){ appendLastRow=appendLastRow, appendAttrValues=appendAttrValues, context=context, - keys=list(alt=mssg$altKey, shift=mssg$shiftKey, ctrl=mssg$ctrlKey, meta=mssg$metaKey, mssg$keycode) + #keys=list(alt=mssg$altKey, shift=mssg$shiftKey, ctrl=mssg$ctrlKey, meta=mssg$metaKey, mssg$keycode) + keys=list(alt=mssg$altKey, shift=mssg$shiftKey, ctrl=mssg$ctrlKey, meta=mssg$metaKey, keycode=mssg$keycode, char=mssg$char) ) tibs<-eval(parse(text=txt), ppenv ) validateTibLists(getPtDefs()$tib, tibs) @@ -87,9 +88,9 @@ preprocTrySetAttrValueS<-function(scripts, ptDefs, rowIndex, selection){ } } }, error=function(e){ - e<-c('preproErr',e) + e<-c('preprocErr',e$message) err<-paste(unlist(e), collapse="\n", sep="\n") - alert(err) + shinyalert("preproc value Errpr",err, type="error") }) } \ No newline at end of file diff --git a/inst/App/rightPanel/preProc/serverAuxPreproc.R b/inst/App/rightPanel/preProc/serverAuxPreproc.R index 3fd52b9d..a17d6706 100644 --- a/inst/App/rightPanel/preProc/serverAuxPreproc.R +++ b/inst/App/rightPanel/preProc/serverAuxPreproc.R @@ -22,39 +22,69 @@ observeEvent(nrow(preProcScriptDB$attrs),{ loadAuxPreProc<-function(fullName){ extractBodyWithComments<-function(fn){ tt<-capture.output(print(fn)) + # remove blank lines + blanks1<-grepl('^ *$',tt) + blanks2<-c(blanks1[-1], FALSE) + bad<-blanks1 #& blanks2 + tt<-tt[!bad] + #drop function beginning + begPos<-min(grep('\\{',tt)) #todo handle case where { not found + if(grepl( "\\{\\s*$", tt[begPos])){ + begPos<-begPos+1 + } else { + bPos<-1+min(unlist(gregexpr('\\{',tt[begPos]))) + tt[begPos]<-substring(tt[begPos],nn) + } + # begPos + #drop function ending + endPos<-max(grep('\\}',tt)) #todo handle case where } not found + if(grepl( "\\S+\\s*\\}\\s*$", tt[endPos])){ + ePos<- -1+max(unlist(gregexpr('\\}',tt[endPos]))) + tt[endPos]<-substring(tt[endPos],ePos) + } else { + endPos<-endPos-1 + } + # endPos + tt<-tt[begPos:endPos] + + #remove indents + nn<-min(unlist(gregexpr('\\S+',tt))) + + tt<-substring(tt,nn) + tt<-paste(tt, collapse="\n") - pos1<-str_locate_all(tt,'\\{')[[1]][1] - if(length(pos1)==0) {stop('ill formed preproc')} - pos2<-str_locate_all(tt,'\\}')[[1]] - if(length(pos2)==0) {stop('ill formed preproc')} - pos1<-pos1[1]+1 - pos2<-pos2[length(pos2)]-1 - substr(tt,pos1,pos2) + tt } + tryCatch({ - preProcList<-source(fullName, local=T)$value + preProcList<-source(fullName, local=TRUE, keep.source=TRUE)$value #check preProcList if(is.null(preProcList) || any(match(names(preProcList), unlist(preprocChoices) , 0 )==0) ){ stop('ill-formed preprocessor') - # todo better message + # todo better error handle } + ppscripts<-lapply(preProcList, extractBodyWithComments) - scriptName=sub('\\.R$','',basename(fullName)) - tb<-tibble(scriptName=scriptName, cmd=names(preProcList), script=ppscripts) + + script.Name=sub('\\.R$','',basename(fullName)) + tb<-tibble(scriptName=script.Name, cmd=names(preProcList), script=ppscripts) - if( "preprocPts"==basename(dirname(fullName))){ + if( "preprocPts"== basename(dirname(fullName))){ + preProcScriptDB$points<-filter(preProcScriptDB$points, scriptName!=script.Name) preProcScriptDB$points<-rbind(preProcScriptDB$points, tb) } else if( "preprocAts"==basename(dirname(fullName))){ + preProcScriptDB$attrs<-filter(preProcScriptDB$attrs, scriptName!=script.Name) preProcScriptDB$attrs<-rbind(preProcScriptDB$attrs, tb) } }, error=function(e){ - e<-c(e,traceback()) + #e0<-paste('attn: err in prepro script',script.Name,"\n") + e<-c(e$message,traceback()) err<-paste(unlist(e), collapse="\n", sep="\n") - alert(err) + shinyalert("preprocErr load",err, type="error") }) } @@ -80,18 +110,24 @@ populatePreProcEditMenu<-function(type=points){ shinyDMDMenu::menuItem(nn, value=paste0('editPP-',type,'-',nn)) }) idd=trimws(paste0('dropDown-editPreProc-',type)) - afterEntry=ifelse(type=='points', 'cmdNewPP', 'cmdNewAP') - label=paste0('Edit preproc ',type) - shinyDMDMenu::insertAfterDMDM( - session, - menuBarId ="plotNavBar", - entry=afterEntry, - submenu= - do.call( - function(...){ menuDropdown( label,...) }, - kids - ) - ) + if(length(kids)>0){ + enableDMDM(session, 'plotNavBar',idd) + afterEntry=ifelse(type=='points', 'cmdNewPP', 'cmdNewAP') + label=paste0('Edit preproc ',type) + shinyDMDMenu::insertAfterDMDM( + session, + menuBarId ="plotNavBar", + entry=afterEntry, + submenu= + do.call( + function(...){ subMenuDropdown( label,...) }, + kids + ) + ) + } else { + disableDMDM(session, 'plotNavBar',idd) + } + } readAuxPreProcs<-function( startup=TRUE){ @@ -102,6 +138,7 @@ readAuxPreProcs<-function( startup=TRUE){ # clear the menus clearPreProcEditMenu('points') clearPreProcEditMenu('attrs') + for(fp in preProcFilePaths){ loadAuxPreProc(fp) } @@ -142,10 +179,10 @@ observeEvent(input$preProcDropDown, { updateRadioButtons(session, "preProcChooser", choices=choices, selected=selected, ) }) -writeAuxPreprocPoints<-function(filePath, scripts){ - txt0<-paste(names(scripts),'= function( pt, context, WH, keys){\n',scripts,"\n}", collapse=",\n") - str_split(txt0, '\n')[[1]]->lines +writeAuxPreprocList<-function(filePath, scripts){ + txt0<-paste0(names(scripts),'= function( pt, context, WH, keys){\n',scripts,"\n}", collapse=",\n") + unlist(str_split(txt0, '\n'))->lines paste0(" ", lines,collapse="\n")->txt1 - txt<-paste0('preprocPts<-list(\n', txt1, "\n)") + txt<-paste0('preprocList<-list(\n', txt1, "\n)") writeLines(txt, filePath) } diff --git a/inst/App/rightPanel/preProc/serverPreProcDB.R b/inst/App/rightPanel/preProc/serverPreProcDB.R index 0d9d421b..5e902f09 100644 --- a/inst/App/rightPanel/preProc/serverPreProcDB.R +++ b/inst/App/rightPanel/preProc/serverPreProcDB.R @@ -1,6 +1,6 @@ preProcPageDB<-reactiveVal( - tibble( tabId="bogus", tibName="bogus", colName='bogus', scriptName='bogus')[0,], + tibble( tabId="bogus", tibName="bogus", colName='bogus', scriptName='bogus')[0,] ) @@ -8,7 +8,7 @@ getPreProcScript<-reactive({ script_Name<-getPreProcScriptName( tab_Id=getTibTabId(), tib_Name=getAssetName(),column_Name= getTibColumnName() ) - if(script_Name!='none'){ + if(!is.null(script_Name) && script_Name!='none'){ if(getColumnType()=='point'){ tb<-filter(preProcScriptDB$points, scriptName==script_Name) } else { @@ -26,7 +26,8 @@ extractPreProcScript<-function(tab_Id, tib_Name, column_Name){ script_Name<-getPreProcScriptName( tab_Id, tib_Name,column_Name ) - if(script_Name!='none'){ + + if(length(script_Name)==1 && script_Name!='none'){ tibs<-getPtDefs()$tib col<-tibs[[tib_Name]][[column_Name]] ctype<-extractColType(col) @@ -78,14 +79,19 @@ setPreProcScriptName<-function(tab_Id, tib_Name, column_Name, script_Name){ } getPreProcScriptName<-function(tab_Id, tib_Name, column_Name){ + if(any(sapply(c(tab_Id, tib_Name, column_Name), is.null)) + || tab_Id=='bogus') + { + return( NULL) + } ppDB<-preProcPageDB() - ppDB<-filter(ppDB, + ppDB<-filter(ppDB, tabId==tab_Id &tibName==tib_Name & colName==column_Name ) if(nrow(ppDB)>0){ ppDB$scriptName } else { - "none" + NULL } } diff --git a/inst/App/rightPanel/preProc/serverPreProcMatMove.R b/inst/App/rightPanel/preProc/serverPreProcMatMove.R index 61b574a1..cebe9a8f 100644 --- a/inst/App/rightPanel/preProc/serverPreProcMatMove.R +++ b/inst/App/rightPanel/preProc/serverPreProcMatMove.R @@ -14,11 +14,11 @@ moveMatrix<-function(dxy=getDxy(), context=context ){ if( is_scalar_numeric(rowIndex) && rowIndex>0 && rowIndex<=nrow(tib) && - is_scalar_numeric(ncol( tib[[ rowIndex, columnIndex]])) + is_scalar_numeric(ncol( tib[[columnIndex]][[rowIndex]])) ){ - m<- tib[[rowIndex, columnIndex ]] - m<-m+dxy - tib[[rowIndex, columnIndex ]]<-tib[[rowIndex, columnIndex ]]+dxy + # m<- tib[[columnIndex]][[rowIndex]] + # m<-m+dxy + tib[[columnIndex]][[rowIndex]]<-tib[[columnIndex]][[rowIndex]]+dxy } tibs[[assetName]]<-tib diff --git a/inst/App/rightPanel/preProc/serverPreProcPtsInsert.R b/inst/App/rightPanel/preProc/serverPreProcPtsInsert.R index e4cf1717..5a90e5ec 100644 --- a/inst/App/rightPanel/preProc/serverPreProcPtsInsert.R +++ b/inst/App/rightPanel/preProc/serverPreProcPtsInsert.R @@ -18,9 +18,9 @@ insertPoint<-function(pt, context=context ){ rowIndex>0 && rowIndex<=nrow(tib) ){ - pts<-tib[[rowIndex,columnIndex]] + pts<-tib[[columnIndex]][[rowIndex]] pts<-append(pts,pt,2*(matColIndex)) - tib[[rowIndex,columnIndex]]<-matrix(pts,2) + tib[[columnIndex]][[rowIndex]]<-matrix(pts,2) tibs[[assetName]]<-tib } } diff --git a/inst/App/rightPanel/preProc/serverPreProcPtsMove.R b/inst/App/rightPanel/preProc/serverPreProcPtsMove.R index a468320c..8a15def7 100644 --- a/inst/App/rightPanel/preProc/serverPreProcPtsMove.R +++ b/inst/App/rightPanel/preProc/serverPreProcPtsMove.R @@ -17,7 +17,7 @@ movePoint<-function(pt, context=context ){ rowIndex>0 && rowIndex<=nrow(tib) ){ - tib[[rowIndex,columnIndex]][,matColIndex] <-pt + tib[[columnIndex]][[rowIndex]][,matColIndex] <-pt tibs[[assetName]]<-tib } } diff --git a/inst/App/rightPanel/selector/serverAssetSelection.R b/inst/App/rightPanel/selector/serverAssetSelection.R index 07943fc0..81285683 100644 --- a/inst/App/rightPanel/selector/serverAssetSelection.R +++ b/inst/App/rightPanel/selector/serverAssetSelection.R @@ -8,9 +8,9 @@ selectedAsset <- reactiveValues( tabId="bogus", - name=NULL, # name of current point array + name=NULL, # name of current point array aka. assetName rowIndex=1, - columnName=NULL, # currently used only by tibbleEditor and could be placed there. + columnName=NULL, # matCol=0, # ptColName=NULL, # !!! KLUDGE for now. should this default to last col? probably not selIndex=1, # only used is to determine if in matrix or point mode !! @@ -19,7 +19,6 @@ selectedAsset <- reactiveValues( ) - getSelIndex<-reactive({ selectedAsset$selIndex }) @@ -33,8 +32,22 @@ observeEvent(getTibNRow(),{ getAssetName<-reactive({selectedAsset$name}) #allow to be null only if tib is null getTibTabId<-reactive({ selectedAsset$tabId}) -getTibColumnName<-reactive({ selectedAsset$columnName }) -getTib<-reactive({ getPtDefs() %$$% 'tib' %$$% getAssetName() }) + +getAssetNames<-reactive({ names(getPtDefs()$tib) }) + +getTibColumnName<-reactive({ + # if(is.null( selectedAsset$columnName)|| !(selectedAsset$columnName %in% names(tib))){ + # selectedAsset$columnName<-tail(names(getTib()),1) + # } + selectedAsset$columnName +}) + +# returns the tib corresponding to selectedAsset$name +# ie. getPtDefs$tib[[ selectedAsset$name ]] +getTib<-reactive({ + getPtDefs() %$$% 'tib' %$$% getAssetName() +}) + getTibColPos<-reactive({ which(names(getTib())==selectedAsset$columnName )}) getTibPtColPos<-reactive({ which(names(getTib())==selectedAsset$ptColName )}) getTibNRow<-reactive({ @@ -50,7 +63,12 @@ atLeast2Rows<-reactive({ }) getTibRow<-reactive({selectedAsset$rowIndex}) -getTibMatCol<-reactive({ selectedAsset$matCol }) +getTibMatCol<-reactive({ + if(is.null(selectedAsset$matCol)){ + selectedAsset$matCol<-0 + } + selectedAsset$matCol +}) getTibPtsNCol<-reactive({ sapply(getTibPts(),ncol)} ) getTransformType<-reactive({ @@ -81,12 +99,21 @@ getTibMatColMax<-reactive({ #' cmd.add.asset #' resetSelectedTibbleName<-function(tibs, name){ - # log.fin(resetSelectedTibbleName) + # log.fin(resetSelectedTibbleName) if(hasError()){ return(NULL) # never change selection when in error state } + choices<-getRightPanelChoices() - # cat("resetSelectedTibbleName:: choices=", paste(choices, collapse=", "),"\n") + aName<-getAssetName() + if( !is.null(aName) && !is.null(getTibRow()) + && !is.null(tibs[[aName]]) && getTibRow()0 && selectedAsset$rowIndex>0){ + rowIndex<-min( selectedAsset$rowIndex,nrow( tib )) + } else { + rowIndex<-nrow( tib ) + } + + if(length(srchVal)==1 && !identical(aName, selectedAsset$name)){ + pos<-grep(srchVal,tib[[selectedAsset$columnName]]) + if(length(pos)>0){ + rowIndex<-tail(pos) + } + } + selectedAsset$rowIndex=rowIndex # next we try to extract a pt column for the selected tib - ptIndxs<-sapply(seq_along(names(tib)),function(j) is.matrix(tib[[rowIndex,j]]) && dim(tib[[rowIndex,j]])[1]==2) - ptIndxs<-which(ptIndxs==TRUE) + ptIndxs<-extractPointColumnIndices(tib) if(length(ptIndxs)>0){ ptColNames<-names(tib)[ptIndxs] if(!is.null(selectedAsset$columnName) && selectedAsset$columnName %in% ptColNames){ @@ -141,11 +179,11 @@ resetSelectedTibbleName<-function(tibs, name){ } } } + resetRowPickeR() if( selectedAsset$name==transformTag){ selectedAsset$transformType='Translate' } - # log.fout(resetSelectedTibbleName) } @@ -179,7 +217,6 @@ updateSelected<-function( name, rowIndex, columnName, matCol, ptColName, selInd if(!is.null(selectedAsset$row) && !is.null(columnName ) && !is.null(selectedAsset$name )){ m<-getPtDefs()$tib[[ selectedAsset$name ]][[columnName]][[selectedAsset$row]] matCol<-selectedAsset$matCol - # cat('matCol=',format(matCol),'\n') if(length(m>0)){ matCol=min(matCol, ncol(m)) } else { @@ -201,24 +238,40 @@ getTibEntry<-reactive({ if( identical(getColumnType(), 'point')){ return( c('point','matrix')[getSelIndex()] ) } + entry<-NULL rowNum<-getTibRow() - if(is.null(rowNum)){ return( NULL)} - columnValues<-getTibEntryChoices() - if(1<=rowNum && rowNum<=length(columnValues) ){ - entry<-columnValues[[rowNum]] - } else { - entry<-NULL + if(length(rowNum)>0){ + columnValues<-getTib() %$$% getTibColumnName() + if(length(columnValues)>0){ + columnValues<-as.list(columnValues) + if(1<=rowNum && rowNum<=length(columnValues) ){ + entry<-columnValues[[rowNum]] + } + } } entry }) getTibEntryChoices<-reactive({ + if( identical(getColumnType(), 'point')){ return( c('point', 'matrix')) } columnValues<-getTib() %$$% getTibColumnName() - if(!is.null(columnValues)){ - columnValues <- as.list(columnValues) + + tab_Id<-getTibTabId() + tib_Name<-getAssetName() + column_Name<-getTibColumnName() + if( length(tab_Id)>0 && length(tib_Name)>0){ + choiceSetName<-getWidget() + if(length(choiceSetName)>0){ + choices<-aux$colChoiceSet[[choiceSetName]] # this is a check to insure consistancy + if(length(choices)>0 && length(setdiff(columnValues, choices))==0 ){ + return(choices) + } else {#if it the check fails should remove from choiceSetPage + #removePageWidgetDB(tab_Id) + } + } } columnValues }) @@ -243,6 +296,19 @@ getTibMatColChoices<-reactive({ rtv }) +getCompatibleChoicesSets<-reactive({ + cs<-aux$colChoiceSet + columnValues<-getTib() %$$% getTibColumnName() + if(length(cs)>0 && length(columnValues)>0){ + fn<-function(choices){ + length(choices)>0 && length(setdiff(columnValues, choices))==0 + } + names(Filter(fn,cs)) + } else { + NULL + } +}) + diff --git a/inst/App/rightPanel/selector/serverAssetSelectionDB.R b/inst/App/rightPanel/selector/serverAssetSelectionDB.R index 9e233754..18b60ea0 100644 --- a/inst/App/rightPanel/selector/serverAssetSelectionDB.R +++ b/inst/App/rightPanel/selector/serverAssetSelectionDB.R @@ -1,17 +1,5 @@ -# serverAssetDB<-reactiveValues( -# tib=tibble( -# tabId="NULL", -# name="NULL", -# rowIndex=1, # row in tibble -# columnName="NULL", # currently used only by tibbleEditor and could be placed there. -# matCol=0, # colIndex of the current matrix. -# ptColName="NULL", # !!! KLUDGE for now. should this default to last col? -# selIndex=1, # only used when current col is points, -# transformType='Translate', -# ptScriptSel=preprocChoices[1] -# )[0,] -# ) + serverAssetDB<-reactiveValues( tib=initialServerAssetDB() ) @@ -49,11 +37,13 @@ restoreAssetState<-function(nextTabId){ row.tib<-serverAssetDB$tib } if(length(row.tib)==0){ - cat(" length(row.tib)==0\n"); browser() #should never happen + cat(" length(row.tib)==0\n"); + browser() #should never happen } - if(nrow(row.tib)==0){ + + if(nrow(row.tib)==0 || length(row.tib) 0){ ptColIndex<-ptIndxs[1] entry<-tib[[rowIndex,ptColIndex]] ptColName<- names(tib)[ptColIndex] + columnName<-ptColName matCol<-ncol(entry) selIndex=1 } else { ptColName<-NULL matCol<-0 } - columnName<-ptColName + if(name==transformTag){ transformType='Translate' } diff --git a/inst/App/rightPanel/selector/serverWidgetHandler.R b/inst/App/rightPanel/selector/serverWidgetHandler.R index 0ffaf4a4..f2f832eb 100644 --- a/inst/App/rightPanel/selector/serverWidgetHandler.R +++ b/inst/App/rightPanel/selector/serverWidgetHandler.R @@ -1,10 +1,4 @@ - -# handler<-reactiveValues( -# choices=initialWidgetDB() -# # choices=tibble(tabId='Tab0', name='x',column='y',type='character',minVal=NA, maxVal=NA,step=1, selectedWidget=NA)[0,] -# ) - widgetDB<-reactiveVal( initialWidgetDB() ) @@ -16,28 +10,31 @@ removePageWidgetDB<-function(pageId){ widgetDB(db) } +allWidgetChoices<-list( + point=c('radio','picker'), + character=c('radio','picker'), #'switch', 'toggle'), + character.list= c('radio','picker'), #, "multiInput", 'picker', 'checkbox'), #range + character.list.2= c('picker','slider','radio'), #, "multiInput", 'picker', 'checkbox'), #range + character.list.vec= c('picker'), #, "multiInput", 'picker', 'checkbox'), #range + #percentage, percentage.list.2 + integer=c('slider', "numeric", 'picker'), #'radio','knob' + numeric=c('picker','slider', "numeric"), #,'knob' + numeric.list=c('picker'), #,'slider', "numeric"), #'radio',,'knob' + numeric.list.2=c('slider'), #,'knob' + integer.list.2=c('slider'), + numeric.list.vec=c('picker'), #,'slider', "numeric"), #'radio',,'knob' + integer.list.vec=c('picker'), #,'slider', "numeric"), #radio', + integer.list=c('picker'), #'radio', + colourable=c('colourable','radio','picker' ) , #'spectrum', 'colorSelectorInput' ), + other=c('picker'), #'radio', + other.list=c('radio','picker') +) - +allWidgetNames<-unique(unlist(allWidgetChoices)) type2WidgetChoices<-function(colType){ if(!is.null(colType)){ - choices<-list( - point=c('radio','picker'), - character=c('radio','picker'), #'switch', 'toggle'), - character.list= c('radio','picker'), #, "multiInput", 'picker', 'checkbox'), #range - character.list.2= c('slider','radio','picker'), #, "multiInput", 'picker', 'checkbox'), #range - character.list.vec= c('radio','picker'), #, "multiInput", 'picker', 'checkbox'), #range - integer=c('radio','picker','slider', "numeric"), #,'knob' - numeric=c('radio','picker','slider', "numeric"), #,'knob' - numeric.list=c('radio','picker'), #,'slider', "numeric"), #,'knob' - numeric.list.2=c('slider'), #,'knob' - integer.list.2=c('slider'), - numeric.list.vec=c('radio','picker'), #,'slider', "numeric"), #,'knob' - integer.list.vec=c('radio','picker'), #,'slider', "numeric"), - colourable=c('radio','picker', 'colourable') , #'spectrum', 'colorSelectorInput' ), - other=c('radio','picker'), - other.list=c('radio','picker') - )[[colType]] + choices<-allWidgetChoices[[colType]] } else { choices<-NULL } @@ -53,85 +50,90 @@ getPageWidgetDB<-function(pageId ){ filter(db, tabId==pageId ) } +# called soley by getWidget: returns a single row from the widgetDB getRowWidgetDB<-reactive({ - # browser() + log.fin(getRowWidgetDB) pageId<- input$pages + row<-NULL if(length(pageId>0)){ wdb<-widgetDB() - tibName<-getAssetName() - colName<-getTibColumnName() - row<-filter(wdb, tabId==pageId & name==tibName & column==colName) - - if(nrow(row)!=1){ #not there or multiple occurances - if(nrow(row)>1){ # remove multiple occurances - wdb<-filter(wdb, !(tabId==pageId & name==tibName & column==colName)) - } - # add back a default - colType<-getColumnType() - widgets<-type2WidgetChoices(colType) - selectedWidget<-widgets[1] - wdb<-add_row(wdb, tabId=pageId, name=tibName, column=colName, - minVal=NA, maxVal=NA, step=1, - selectedWidget=selectedWidget) - widgetDB(wdb) - row<-filter(wdb, tabId==pageId & name==tibName & column==colName) + tibName<-getAssetName() + colName<-getTibColumnName() + row<-filter(wdb, tabId==pageId & name==tibName & column==colName) + widgets<-getWidgetChoices() + if(nrow(row)!=1 || !(row$selectedWidget %in% widgets) ){ # begin patch + if(nrow(row)>0){ # remove any existing rowss + wdb<-filter(wdb, !(tabId==pageId & name==tibName & column==colName)) + } + # and add back a default + colType<-getColumnType() + #widgets<-getWidgetChoices() + chosenWidget<-widgets[1] + if(chosenWidget %in% aux$colChoiceSet){ + colType<-'choiceSet' + } + wdb<-add_row(wdb, + tabId=pageId, name=tibName, + column=colName, type=colType, + minVal=NA, maxVal=NA, # may need to rethink these NA's + step=1, selectedWidget=chosenWidget + ) + widgetDB(wdb) + row<-filter(wdb, tabId==pageId & name==tibName & column==colName) + } # end of patch + log.fout(getRowWidgetDB) } row - } - }) # TODO: populate handler with rows as needed: newPage or tabChange or ... # TODO: rewrite to update just minVal or maxVal or step or selectedWidget updateWidgetChoicesRow<-function(#tibName, colName, colType, - minVal=NA, maxVal=NA, step=1, selectedWidget='radio'){ # use current tib and col + minVal=NA, maxVal=NA, step=1, selectedWidget){ # use current tib and col + log.fin(updateWidgetChoicesRow) + + # can we really trust the following? pageId<- input$pages tibName<-getAssetName() colName<-getTibColumnName() - - - log.fin(updateWidgetChoicesRow) if(length(pageId)>0){ - + wdb<-widgetDB() rowNo<-which( wdb$tabId==pageId & wdb$name==tibName & wdb$column==colName - ) - if(length(rowNo)==1){ #not much changes, just replace selected (assuming selected in colVal) + ) + isCS<-FALSE + if(length(aux$colChoiceSet)>0 && selectedWidget %in% names(aux$colChoiceSet)){ + columnValues<-getTib() %$$% getTibColumnName() + valueChoices<-aux$colChoiceSet[[selectedWidget]] + isCS<-(length(valueChoices)>0 && length(setdiff(columnValues, valueChoices))==0 ) + } + if(length(rowNo)==1 && !isCS){ #not much changes, just replace selected (assuming selected in colVal) nn<-names(match.call()[-1]) for(n in nn){ wdb[[n]][rowNo]<-get(n) } } else { # not there, or multiple rows? - colType<-getColumnType() - widgets<-type2WidgetChoices(colType) - if(!selectedWidget %in% widgets){ - selectedWidget<-widgets[1] + widgets<-getWidgetChoices() + chosenWidget<-selectedWidget #kludge to avoid name clash + log.val(chosenWidget) + if(!isCS && !chosenWidget %in% widgets){ + # cat('should not happen\n') + chosenWidget<-widgets[1] + } + if(isCS){ + colType<-'choiceSet' + log.val(colType) } tmp<-wdb[!(wdb$tabId==pageId & wdb$name==tibName & wdb$column==colName),] #remove the row why? - wdb<-add_row(wdb, tabId=pageId, name=tibName, column=colName, minVal=minVal, maxVal=maxVal, step=step, selectedWidget=selectedWidget) + wdb<-add_row(tmp, tabId=pageId, name=tibName, column=colName, + type=colType , minVal=minVal, maxVal=maxVal, step=step, selectedWidget=chosenWidget) } widgetDB(wdb) log.fout(updateWidgetChoicesRow) - # rowNo<-which( - # handler$choices$tabId==tabId & - # handler$choices$name==tibName & - # handler$choices$column==colName - # ) - # if(length(rowNo)>0){ #not much changes, just replace selected (assuming selected in colVal) - # nn<-names(match.call()[-1]) - # for(n in nn){ - # handler$choices[[n]][rowNo]<-get(n) - # } - # } else { #remove the row - # widgets<-type2WidgetChoices(colType) - # - # tmp<-handler$choices[!(handler$choices$tabId==tabId & handler$choices$name==tibName & handler$choices$column==colName),] - # handler$choices<-add_row(tmp, tabId=tabId, name=tibName, column=colName, minVal=minVal, maxVal=maxVal, step=step, selectedWidget=selectedWidget) - # } } } @@ -140,46 +142,50 @@ updateWidgetChoicesRow<-function(#tibName, colName, colType, getWidgetChoices<-reactive({ colType<-getColumnType() widgetChoices<-type2WidgetChoices(colType) + tabId<- getTibTabId() + tibName<-getAssetName() + colName<-getTibColumnName() + cs<-getCompatibleChoicesSets() + widgetChoices<-c(widgetChoices,cs) #prioritize cs + log.val(widgetChoices) + scriptName<-getPreProcScriptName(tab_Id=tabId, tib_Name=tibName, column_Name=colName) + if(getPlotState()=='value' && !is.null(scriptName) ){ + widgetChoices<- c( "immutable", widgetChoices) + } + widgetChoices }) +# called by +# serverEdTib init (line 33) +# then moduleEdTib (lines 108, 128), both by conditon: getTibEditState()==TRUE getWidget<-reactive({ - # cat('entering getWidget\n') - # widgets<-getWidgetChoices() - # widget<-widgets[1] - # colName<-getTibColumnName() - # columnValues<-getTib()[[colName]] - # row<-filter(widgetDB(), - # tabId==getTibTabId() & - # name==getAssetName() & - # column==getTibColumnName() - # ) - # if(nrow(row)==0 ){ - # selectedWidget<-getWidgetChoices()[1] - # } else if(nrow(row)=1 ){ # found - # selectedWidget<-row$selectedWidget - # if( !(selectedWidget %in% widgets) ){ - # browser() - # selectedWidget<-getWidgetChoices()[1] - # } - # } else { # stop - # browser() - # stop('corrupted widgets') - # } - # browser() - rtv<-getRowWidgetDB()$selectedWidget - # browser() - rtv - #return(selectedWidget) + # log.fin(getWidget) + + rdb<-getRowWidgetDB() + + + if(nrow(rdb)==1){ #look ok so far + selectedWidget<-rdb$selectedWidget + # check if compatible: looping issue when changing to new tab + # if(!is.null(selectedWidget) && selectedWidget %in% names(aux$colChoiceSet ) ){ + # columnValues<-getTib() %$$% getTibColumnName() + # valueChoices<-aux$colChoiceSet[[selectedWidget]] + # isCS<-(length(valueChoices)>0 && length(setdiff(columnValues, valueChoices))==0 ) + # if(!isCS){ + # selectedWidget<-NULL #or first choice? + # } + # } + } else { + selectedWidget<-NULL + } + + # log.fin(getWidget) + selectedWidget }) -# getWidgetVal<-reactive({ -# tabId<-input$pages -# # row<-filter(handler$choices, tabId==tabId, name==getAssetName(), column==getTibColumnName()) -# row<-filter(widgetDB(), tabId==tabId & name==getAssetName() & column==getTibColumnName()) -# }) + getPointMax<-reactive({ - # cat('\n---Entering -getPointMax---------\n') selectedTabId<-getTibTabId() colMax<-filter(widgetDB(), @@ -188,7 +194,6 @@ getPointMax<-reactive({ column==getTibColumnName() )$maxVal - # colMax<-filter(handler$choices, tabId== getTibTabId() , name==getAssetName(), column==getTibColumnName())$maxVal if(length(colMax)==0 ){ #or length(colMax)!=1 NA } else { @@ -196,4 +201,23 @@ getPointMax<-reactive({ } }) +# tibble(tabId='Tab0', name='x',column='y',type='character',minVal=NA, maxVal=NA,step=1, selectedWidget='radio') +pruneDeadRowsFromWidgetDB<-function(){ + db<-widgetDB() + tibs<-getPtDefs()$tib + if(nrow(db)>0){ + v<-unlist(pmap(db, function(tabId, name, column, type, minVal, maxVal, step, selectedWidget){ + # print(getTibTabId()) + # print(column) + # print(name) + # print(names(tibs[[name]])) + tabId!= getTibTabId() || + (name %in% names(tibs) && column %in% names(tibs[[name]])) + })) + + db<-filter(db, v) + } + widgetDB(db) +} + diff --git a/inst/App/rightPanel/serverDisplayOptions.R b/inst/App/rightPanel/serverDisplayOptions.R index ee6f10d1..1e8df382 100644 --- a/inst/App/rightPanel/serverDisplayOptions.R +++ b/inst/App/rightPanel/serverDisplayOptions.R @@ -2,7 +2,10 @@ # controls display of svg rendering displayOptions<-reactiveValues( insertMode=TRUE, - ptMode="Normal" # can be 'Hidden', 'Normal', 'Labeled' + ptMode="Normal", # can be 'Hidden', 'Normal', 'Labeled' + labelMode=FALSE, + restrictMode=FALSE, + labelColor='#000000' ) #displayMode<-reactive({displayOptions$ptMode}) @@ -22,7 +25,13 @@ getDisplayMode<-reactive({ }) -setDisplayOption<-function( insertMode, ptMode ){ +setDisplayOption<-function( insertMode, ptMode, labelMode, restrictMode ){ + if(!missing(labelMode)){ + displayOptions$labelMode<-labelMode + } + if(!missing(restrictMode)){ + displayOptions$restrictMode<-restrictMode + } if(!missing(insertMode)){ displayOptions$insertMode<-insertMode } @@ -30,6 +39,9 @@ setDisplayOption<-function( insertMode, ptMode ){ displayOptions$ptMode<-ptMode } } +getDisplayOptions<-reactive({ + tmp<-reactiveValuesToList(displayOptions) #how can this possibly work??? +}) diff --git a/inst/App/rightPanel/serverOptions.R b/inst/App/rightPanel/serverOptions.R index 356bdaf0..7f410d7b 100644 --- a/inst/App/rightPanel/serverOptions.R +++ b/inst/App/rightPanel/serverOptions.R @@ -14,8 +14,8 @@ pprj<-reactiveVal(initialProj) getDirPath<-reactive({ if(!is.null(editOption$currentProjectName) && !is.null(editOption$currentProjectDirectory)){ dirPath<-editOption$currentProjectDirectory - if(!file.exists(dirPath)){ - dirPath<-optionDirPath() + if(!file.exists(dirPath)){ # currentProjectDirectory not found!! + dirPath<-optionDirPath() # this sets dirPath to ~/ptr editOption$currentProjectName=NULL editOption$currentProjectDirectory=NULL } @@ -109,6 +109,7 @@ mkFileSubMenu<-function(subMenuLabel, prefix, fullFilePaths){ } if(length(files)>0){ # 4 make submenu + files<-normalizePath(files) files<-unique(files) values<-paste(prefix,files, sep="-") labels<-basename(files) @@ -116,13 +117,13 @@ mkFileSubMenu<-function(subMenuLabel, prefix, fullFilePaths){ mkmenuitem<-function(label, value, hint){ shinyDMDMenu::menuItem( label=label, - value=value, - span(hint, class='tooltiptext') + value=value # , + # span(hint, class='tooltiptext') ) } items<-mapply(mkmenuitem, label=labels, value=values, hint=hints, SIMPLIFY = FALSE, USE.NAMES = FALSE) - submenu=do.call( function(...){ menuDropdown(subMenuLabel,...) }, items) + submenu=do.call( function(...){ subMenuDropdown(subMenuLabel,...) }, items) } else{ submenu=NULL } @@ -135,34 +136,43 @@ observeEvent( editOption$recentProjects ,{ removeDMDM(session=session, menuBarId="editNavBar", entry=subMenuLabel) # 2 get files to populate submenu files<-unlist(editOption$recentProjects) + # NEED TO CHECK IF FILES STILL EXIST!!! + files<-files[file.exists(files)] # 3 create submenu + if(length(files)>0){ submenu<-mkFileSubMenu( subMenuLabel= subMenuLabel, prefix='recentProj', files) # 4 insertsubmenu - if(!is.null(submenu)){ - insertAfterDMDM( - session, menuBarId = "editNavBar", - entry="openProject", submenu= submenu - ) + if(!is.null(submenu)){ + insertAfterDMDM( + session, menuBarId = "editNavBar", + entry="openProject", submenu= submenu + ) + } } -}) +}, ignoreNULL=FALSE) #menu item is remove if editOption$recentPproj is null # must both add and delete entries. observeEvent( editOption$recentFiles ,{ - # 1 remove menuDropdown - removeDMDM(session=session, menuBarId="editNavBar", entry="Recent Files") + # 1 remove subMenuDropdown + subMenuLabel= "Recent Files" + removeDMDM(session=session, menuBarId="editNavBar", entry=subMenuLabel) # 2 get files to populate submenu files<-unlist(editOption$recentFiles) + # NEED TO CHECK IF FILES STILL EXIST!!! + files<-files[file.exists(files)] # 3 create submenu - submenu<-mkFileSubMenu( subMenuLabel= "Recent Files", prefix="recentFile", files) - # 4 insertsubmenu - if(!is.null(submenu)){ - insertAfterDMDM( - session, menuBarId = "editNavBar", - entry="openFile", submenu= submenu - ) + if(length(files)>0){ + submenu<-mkFileSubMenu( subMenuLabel= subMenuLabel, prefix="recentFile", files) + # 4 insertsubmenu + if(!is.null(submenu)){ + insertAfterDMDM( + session, menuBarId = "editNavBar", + entry="openFile", submenu= submenu + ) + } } -}) +}, ignoreNULL=FALSE) #menu item is remove if editOption$recentFiles is null # observeEvent(editOption$whiteSpace,{ # newLabel<-ifelse(editOption$whiteSpace, "Hide White Space", "Show White Space") diff --git a/inst/App/rightPanel/serverPanelCoordinator.R b/inst/App/rightPanel/serverPanelCoordinator.R index 741a4ebe..7660b2fe 100644 --- a/inst/App/rightPanel/serverPanelCoordinator.R +++ b/inst/App/rightPanel/serverPanelCoordinator.R @@ -59,12 +59,15 @@ getNameType<-reactive({ # 3. getTibEntry, getTibEntryChoices # and use it only for whether or not the column is a 'points' column. getColumnType<-reactive({ - colName<-getTibColumnName() - columnValues<-getTib()[[colName]] - if(!is.null(columnValues)){ - return(extractColType(columnValues)) + ctype=NULL + colName<-getTibColumnName() # i.e. selectedAsset$columnName + if(!is.null(colName)){ + columnValues<-getTib()[[colName]] + if(!is.null(columnValues)){ + ctype=extractColType(columnValues) + } } - return(NULL) + return(ctype) }) # returns the state: 'point', 'matrix', 'value', transformTag, RPanelTag, errorPanelTag @@ -75,13 +78,18 @@ getColumnType<-reactive({ getPlotState<-reactive({ nameType<-getNameType() if(identical(nameType,tibTag)){ + # Tools + enableDMDM(session, 'plotNavBar','Tools') colType<-getColumnType() - if(identical(colType,'point')){ + if(is.null(colType)){ + rtv<-NULL #should never happen!!! + } else if(identical(colType,'point')){ rtv<-c('point', 'matrix')[ getSelIndex() ] } else { rtv<-'value' } } else { + disableDMDM(session, 'plotNavBar','Tools') rtv<-nameType } rtv @@ -147,18 +155,43 @@ label= 'getRightPanelChoices' ) -observeEvent(c(getSourceType(), hasError()),{ +observeEvent(c(getSourceType(), hasError(), getParMode() ),{ if(!hasError() && identical(getSourceType(), svgPanelTag)){ enableDMDM( session, menuBarId="plotNavBar", entry="Grid" ) - enableDMDM( - session, - menuBarId="plotNavBar", - entry="Backdrop" - ) + if(is.null(getParMode()) ){ + enableDMDM( + session, + menuBarId="plotNavBar", + entry="Backdrop" + ) + enableDMDM( + session, + menuBarId="plotNavBar", + entry="cmdAdjustGridSpacing" + ) + enable(id='tagValBar-newColumnButton') + } else { + disableDMDM( + session, + menuBarId="plotNavBar", + entry="Backdrop" + ) + disableDMDM( + session, + menuBarId="plotNavBar", + entry="cmdAdjustGridSpacing" + ) + if(identical(getParMode(), 'dnippets')){ + disable(id='tagValBar-newColumnButton') + } else { + enable(id='tagValBar-newColumnButton') + } + + } } else { disableDMDM( session, diff --git a/inst/App/rightPanel/serverPanelDispatch.R b/inst/App/rightPanel/serverPanelDispatch.R index d1db5fff..cdb73534 100644 --- a/inst/App/rightPanel/serverPanelDispatch.R +++ b/inst/App/rightPanel/serverPanelDispatch.R @@ -21,6 +21,9 @@ output$BottomRightPanel<-renderUI({ output$MidRightPanel<-renderUI({ # cat(">---> output$MidRightPanel\n") chosenRightMidPanel<-getRightMidPanel() + if(is.null(chosenRightMidPanel)){ + chosenRightMidPanel<-'NA' + } # cat("chosenRightMidPanel=",format(chosenRightMidPanel),"\n") if (chosenRightMidPanel=='point'){ # cat("chosenRightMidPanel=1\n") @@ -50,22 +53,21 @@ output$MidRightPanel<-renderUI({ # cat('************ inside output$MidRightPanel: aptRunner***************\n') moduleLogUI("aptRunnerLogMod", input, output) } else { - div( img(src="ptR/pointRLogo.SVG") ) + div(img(src="ptR/pointRlogo.svg")) } } else if( chosenRightMidPanel == rmdPanelTag ){ # cat("chosenRightMidPanel=8\n") modulePlotRmdUI("rmdMod", input, output) } else if(chosenRightMidPanel == textPanelTag){ # cat("chosenRightMidPanel=9\n") - div( img(src="ptR/pointRLogo.SVG") ) + div(img(src="ptR/pointRlogo.svg")) #Todo add something about sponsors. } else if(chosenRightMidPanel == snippetPanelTag){ # cat("chosenRightMidPanel=10\n") - div( img(src="ptR/pointRLogo.SVG") ) + div(img(src="ptR/pointRlogo.svg")) #Todo add something about sponsors. } else { - # cat("chosenRightMidPanel=11\n") - div( img(src="ptR/pointRLogo.SVG")) + div(img(src="ptR/pointRlogo.svg")) } diff --git a/inst/App/sampleProjects/FeymanGraphs/.workspace/PTR-TABID3f943c89a3ab.rda b/inst/App/sampleProjects/FeymanGraphs/.workspace/PTR-TABID3f943c89a3ab.rda deleted file mode 100644 index 1f210838..00000000 Binary files a/inst/App/sampleProjects/FeymanGraphs/.workspace/PTR-TABID3f943c89a3ab.rda and /dev/null differ diff --git a/inst/App/sampleProjects/FeymanGraphs/.workspace/currentTab.rda b/inst/App/sampleProjects/FeymanGraphs/.workspace/currentTab.rda deleted file mode 100644 index d255baf8..00000000 Binary files a/inst/App/sampleProjects/FeymanGraphs/.workspace/currentTab.rda and /dev/null differ diff --git a/inst/App/sampleProjects/FeymanGraphs/Feyman.R b/inst/App/sampleProjects/FeymanGraphs/Feyman.R deleted file mode 100644 index ac4d2735..00000000 --- a/inst/App/sampleProjects/FeymanGraphs/Feyman.R +++ /dev/null @@ -1,16 +0,0 @@ -library(svgR) -library(tidyverse) -WH<-c(600,400) - -# Defined by mouse: edit with care! -ptR<-list( - x=tribble( - ~points, - matrix(NA,2,0) - ) -) - -svgR(wh=WH, - #your custom code goes here - NULL -) diff --git a/inst/App/sampleProjects/FeymanGraphs/FeymanGraphs.pprj b/inst/App/sampleProjects/FeymanGraphs/FeymanGraphs.pprj deleted file mode 100644 index ffe0eeb4..00000000 --- a/inst/App/sampleProjects/FeymanGraphs/FeymanGraphs.pprj +++ /dev/null @@ -1,12 +0,0 @@ -{ - "pathToProj": [ - "/home/sup/BB/FeymanGraphs" - ], - "projName": [ - "FeymanGraphs.pprj" - ], - "projType": [ - "generic" - ] -} - diff --git a/inst/App/sampleProjects/autoArrow/.workspace/PTR-TABID308f46cf0aa0.rda b/inst/App/sampleProjects/autoArrow/.workspace/PTR-TABID308f46cf0aa0.rda deleted file mode 100644 index f4a607c2..00000000 Binary files a/inst/App/sampleProjects/autoArrow/.workspace/PTR-TABID308f46cf0aa0.rda and /dev/null differ diff --git a/inst/App/sampleProjects/autoArrow/.workspace/currentTab.rda b/inst/App/sampleProjects/autoArrow/.workspace/currentTab.rda deleted file mode 100644 index 39dd3a6c..00000000 Binary files a/inst/App/sampleProjects/autoArrow/.workspace/currentTab.rda and /dev/null differ diff --git a/inst/App/sampleProjects/autoArrow/autoArrow.R b/inst/App/sampleProjects/autoArrow/autoArrow.R deleted file mode 100644 index 56dda29a..00000000 --- a/inst/App/sampleProjects/autoArrow/autoArrow.R +++ /dev/null @@ -1,70 +0,0 @@ -library(svgR) -library(tidyverse) -WH<-c(800,600) - -# 1. ensure that the attribute preprocessor for circle$id -# is set to 'fromtolinking' -# 2. When a new circle is created via a mouse click, -# an id will be generated for that circle -# 3. To create an arrow connecting a two circles: -# i. Select the id of first circle while pressing the 'a' key -# ii. Select the id of second circle while pressing the 'b' key -# note: if step ii is not done, the arrow will point to the last to circle - -# Defined by mouse: edit with care! -ptR<-list( - circle= tribble( - ~id, ~fill, ~cxy, - 'yemedaxb', '#E06262', matrix( c(c(367.5,330)), 2), - 'jfnwfdhl', '#EAFF00', matrix( c(c(315.5,183)), 2), - 'ncipjeju', '#FF00EA', matrix( c(c(191,200)), 2), - 'tqtyjzpm', '#0CC9C9', matrix( c(c(485,151)), 2), - 'udrtlyzw', '#61E619', matrix( c(c(382.5,62)), 2), - 'chmnkvnq', '#099161', matrix( c(c(508,293)), 2), - 'rdkqglru', '#FF0000', matrix( c(c(67,89)), 2), - 'pkztfnpg', '#0011FF', matrix( c(c(137,380)), 2) - ), - links= tribble( - ~fromId, ~toId, ~points, - 'tqtyjzpm', 'udrtlyzw', matrix(0,2,0), - 'tqtyjzpm', 'yemedaxb', matrix(0,2,0), - 'chmnkvnq', 'tqtyjzpm', matrix(0,2,0), - 'cfqzzhcj', 'rdkqglru', matrix(0,2,0), - 'rdkqglru', 'cfqzzhcj', matrix(0,2,0), - 'japgmptb', 'ncipjeju', matrix(0,2,0), - 'japgmptb', 'jfnwfdhl', matrix(0,2,0), - 'ncipjeju', 'rdkqglru', matrix(0,2,0), - 'pkztfnpg', 'jfnwfdhl', matrix(0,2,0) - ) -) - -arrs<-ptR$links %>% - inner_join( ptR$circle, by=c('fromId'='id') )%>% - inner_join( ptR$circle, by=c('toId'='id') ) %>% - select(c(5,7)) %>% - rename(p1=cxy.x, p2=cxy.y) - - -R=50 - - -arrow% - - - - - - diff --git a/inst/App/sampleProjects/shinyDialInput/widget.pprj b/inst/App/sampleProjects/shinyDialInput/widget.pprj deleted file mode 100644 index 273b901a..00000000 --- a/inst/App/sampleProjects/shinyDialInput/widget.pprj +++ /dev/null @@ -1 +0,0 @@ -{"pathToProj":["~/AA/widget"],"projName":["widget.pprj"],"projType":[[[[[["generic"]]]]]]} diff --git a/inst/App/sampleProjects/shinyDialInput/widgetCntrl.R b/inst/App/sampleProjects/shinyDialInput/widgetCntrl.R deleted file mode 100644 index b4fd54a7..00000000 --- a/inst/App/sampleProjects/shinyDialInput/widgetCntrl.R +++ /dev/null @@ -1,89 +0,0 @@ -library(shiny) -library(svgR) - -try({ removeInputHandler("widgetCntrlBinding") }) - -widgetSvgCntrl<-function(params){ - source('widget_svg.R', local=T)$value -} - -newWidgetCntrl<-function(WH, theta0, CXY, R, CMD ){ - svg<-widgetSvgCntrl(list(WH=WH, theta0=theta0, CXY=CXY, R=R, CMD=CMD)) - HTML(as.character(svg)) -} - -widgetCntrl<-function(inputId, wh, theta0=0){ - cxy<-c(.5,.9)*wh - r<-.4*wh[1] - CMD=sprintf('widgetCntrlBinding.clicked("%s", evt)',inputId) - tagList( - singleton(tags$head(tags$script(src = "widget.js"))), - div( id=inputId, - class="widgetCntrl", # - "data-theta"=theta0, # customize for initialization - 'data-x'=cxy[1], - 'data-y'=cxy[2], - newWidgetCntrl(WH=wh, theta0=theta0, CXY=cxy, R=r, CMD=CMD) - ) - ) -} - -updateWidgetCntrl<-function(session, inputId, wh=c(300,200), value=NULL){ - if(!is.null(value)){ - theta=value - cxy<-c(.5,.9)*wh - r<-.4*wh[1] - CMD=sprintf('widgetCntrlBinding.clicked("%s", evt)',inputId) - node<-as.character(newWidgetCntrl(WH=wh, theta0=theta, CXY=cxy, R=r, CMD=CMD)) - mssg<-list(value=node) - session$sendInputMessage(inputId, mssg) - } - - # mssg<-list(value=value) - # use theta to generate new svg script - # get new svg as script - # send message to name to update script - # return value of theta as list - - if(length(mssg)>0){ - session$sendInputMessage(inputId, mssg) - } -} - -shiny::registerInputHandler( - "widgetCntrlBinding", - function(val, shinysession, name) { - - if(is.null(val) || is.null(val$dXY$x)) { - return(NULL) - } else { - # Parse return value from JSON into R format dataframe - # browser() - dxy<-val$dXY - theta<-90-(180*atan(dxy$x/dxy$y))/pi - cxy<-unlist(val$CXY) - # recompute WH from CXY as - wh<-cxy/c(.5,.9) - # then R by - r<-0.4*wh[1] - inputId<-name - CMD=sprintf('widgetCntrlBinding.clicked("%s", evt)',inputId) - node<-as.character(newWidgetCntrl(WH=wh, theta0=theta, CXY=cxy, R=r, CMD=CMD)) - mssg<-list(value=node) - shinysession$sendInputMessage(inputId, mssg) - - #xy <- jsonlite::fromJSON(x) - # convert xy into theta - - # get new svg as script - # send message to name to update script - # return value of theta as list - - # Extract the values of the data frame as a list - - - return(theta) - } - } -) - diff --git a/inst/App/sampleProjects/shinyDialInput/widget_svg.R b/inst/App/sampleProjects/shinyDialInput/widget_svg.R deleted file mode 100644 index 2ff20de6..00000000 --- a/inst/App/sampleProjects/shinyDialInput/widget_svg.R +++ /dev/null @@ -1,103 +0,0 @@ -library(svgR) -library(tidyverse) - - -WH<-c(400,200) -theta0<-45 -CXY<-c(.5,.9)*WH -R<-.4*WH[1] -CMD<-"" -R0<-10 - -#----------function override of params---------- -if(exists("params") ){ - for(n in names(params)){ - assign(n, params[[n]]) - } -} - -theta2pos<-function(theta, cxy=CXY, r=R){ - theta<-pi*theta/180 - cxy+r*c(cos(theta),-sin(theta)) -} - -pos2theta<-function(pos, cxy=CXY){ - pos<-pos-cxy - if(abs(pos[1])>.0001){ - theta<-pi/2 - } else { - theta<-atan(-pos[2]/pos[1]) - } - 180*(theta)/pi -} - -descriptor<-function(theta, cxy=CXY, r=R){ - d=list( - M=CXY, - L=theta2pos(0), - A=c( c(R,R), 180,0,0,theta2pos(theta)), - Z=1 - ) -} - -descriptor2<-function( dR=10){ - d=list( - M=CXY-c(R+dR,0), - A=c( c(R,R)+dR, 0,1,1,CXY+c(R+dR,0)), - L=CXY+c(R-dR,0), - A=c(c(R,R)-dR, 0,1,0,CXY+c(-R+dR,0)), - Z=0 - ) -} - - -svgR(wh=WH, - #your custom code goes here - g( - rect(xy=c(0,CXY[2]),wh=WH , fill='#AA88FF', - transform=list(rotate=c(0,CXY)) - ), - clip.path= clipPath( path(d=descriptor(180))) - ), - g( - path( d=descriptor(180),stroke='black', - stroke.width=2*R0, - fill=radialGradient(fxy=c(.5,.9),colors=c('lightblue', 'blue', 'black')), - onClick=CMD - ), - path( d=descriptor2(), stroke='black', - fill=linearGradient(colors=c('brown', 'white','yellow')), - onClick=CMD - ), - lapply(seq.int(from=0,to=180,by=10),function(i){ - xy1<-CXY+c(0,-R+R0) - xy2<-CXY+c(0,-R-R0) - xy3<-CXY+c(0,-R-2*R0) - g( - text(cxy=xy3,i, font.size=8), - line(xy1=xy1,xy2=xy2, stroke='black'), - transform=rotate(i-90,CXY), - onClick=CMD - ) - }) - ), - g( - line( xy1=CXY, xy2=CXY+c(0,-R+R0+2), stroke='white', stroke.width=2, - marker.end= - marker( - viewBox=c(0, 0, 10, 10), - refXY=c(10,5), - fill='white', - markerWidth=8, markerHeight=8, orient="auto", - path( d=c("M", 0, 0, "L", 10, 5, "L", 0, 10, "z") ) - ) - ), - transform=rotate(theta0-90,CXY) - ), - circle( cxy=CXY, r=R0, stroke='blue', - fill=radialGradient(colors=c('white','brown')) - ) -) - - - diff --git a/inst/App/sampleProjects/shinyDialInput/www/widget.js b/inst/App/sampleProjects/shinyDialInput/www/widget.js deleted file mode 100644 index 797f97f0..00000000 --- a/inst/App/sampleProjects/shinyDialInput/www/widget.js +++ /dev/null @@ -1,74 +0,0 @@ -// Javascript -//BEGIN: INPUT BINDING -var widgetCntrlBinding = new Shiny.InputBinding(); -$.extend(widgetCntrlBinding, { - find: function(scope) { - console.log('find'); - return $(scope).find(".widgetCntrl"); - }, - initialize: function(el){ - // Initialize any data values here - $(el).data('dXY',{ - x:Number($(el).attr("data-dx")), - y:Number($(el).attr("data-dy")) - }); - $(el).data('CXY',{ - x:Number($(el).attr("data-x")), - y:Number($(el).attr("data-y")) - }); - }, - getValue: function(el) {// used to return the value of the input control - //return $(el).data('dXY'); //we return mouse position relative to svg - return { - dXY:$(el).data('dXY'), - CXY:$(el).data('CXY') - }; - }, - setValue: function(el, value) { // used for updating input control - // theta value is assumed to be in degrees - $(el).data('dXY',value); - $(el).trigger("change"); - }, - subscribe: function(el, callback) { - // notify server whenever change - $(el).on("change.widgetCntrlBinding", function(e) { - callback(); - }); - }, - unsubscribe: function(el) { - $(el).off(".widgetCntrlBinding"); - }, - receiveMessage: function(el, data) { //called by server when updating - if(!!data.value){ - //var id=$(el).attr('id'); - var htm=data.value; //assumed to be in degrees - var node=jQuery.parseHTML( htm ); - $(el).empty().append(node); - //this.setValue($(el), data.value); //record value - } - }, - mouse2pt: function(id, x, y){ //method to convert mouse coord to svg coord - var thisSVG=document.querySelector("#" + id +" svg"); - var pt= thisSVG.createSVGPoint(); - pt.x = x; - pt.y = y; - return pt.matrixTransform(thisSVG.getScreenCTM().inverse()); - }, - clicked: function(ctrlId, evt ){ - var pt = this.mouse2pt(ctrlId, evt.clientX, evt.clientY); - var el = "#" + ctrlId; - this.setValue("#" + ctrlId, - { - x: pt.x-$(el).data("CXY").x, - y: pt.y-$(el).data("CXY").y - } - ); - }, - getType: function(el){ - return "widgetCntrlBinding"; - } -}); - -// register input binding -Shiny.inputBindings.register(widgetCntrlBinding); - diff --git a/inst/App/sampleProjects/shinyDialInputOptimized/.workspace/PTR-TABID25d9190dff34.rda b/inst/App/sampleProjects/shinyDialInputOptimized/.workspace/PTR-TABID25d9190dff34.rda deleted file mode 100644 index 046f377c..00000000 Binary files a/inst/App/sampleProjects/shinyDialInputOptimized/.workspace/PTR-TABID25d9190dff34.rda and /dev/null differ diff --git a/inst/App/sampleProjects/shinyDialInputOptimized/.workspace/PTR-TABID25d96494b000.rda b/inst/App/sampleProjects/shinyDialInputOptimized/.workspace/PTR-TABID25d96494b000.rda deleted file mode 100644 index 6a9b00d0..00000000 Binary files a/inst/App/sampleProjects/shinyDialInputOptimized/.workspace/PTR-TABID25d96494b000.rda and /dev/null differ diff --git a/inst/App/sampleProjects/shinyDialInputOptimized/.workspace/PTR-TABID3a76585f47c.rda b/inst/App/sampleProjects/shinyDialInputOptimized/.workspace/PTR-TABID3a76585f47c.rda deleted file mode 100644 index dbb8d888..00000000 Binary files a/inst/App/sampleProjects/shinyDialInputOptimized/.workspace/PTR-TABID3a76585f47c.rda and /dev/null differ diff --git a/inst/App/sampleProjects/shinyDialInputOptimized/.workspace/PTR-TABIDa9527235bba.rda b/inst/App/sampleProjects/shinyDialInputOptimized/.workspace/PTR-TABIDa9527235bba.rda deleted file mode 100644 index 7d435b41..00000000 Binary files a/inst/App/sampleProjects/shinyDialInputOptimized/.workspace/PTR-TABIDa9527235bba.rda and /dev/null differ diff --git a/inst/App/sampleProjects/shinyDialInputOptimized/.workspace/PTR-TABIDa954e443c9d.rda b/inst/App/sampleProjects/shinyDialInputOptimized/.workspace/PTR-TABIDa954e443c9d.rda deleted file mode 100644 index e3af9fa4..00000000 Binary files a/inst/App/sampleProjects/shinyDialInputOptimized/.workspace/PTR-TABIDa954e443c9d.rda and /dev/null differ diff --git a/inst/App/sampleProjects/shinyDialInputOptimized/.workspace/loadedDnippets.rda b/inst/App/sampleProjects/shinyDialInputOptimized/.workspace/loadedDnippets.rda deleted file mode 100644 index c7648548..00000000 Binary files a/inst/App/sampleProjects/shinyDialInputOptimized/.workspace/loadedDnippets.rda and /dev/null differ diff --git a/inst/App/sampleProjects/shinyDialInputOptimized/app.R b/inst/App/sampleProjects/shinyDialInputOptimized/app.R deleted file mode 100644 index 04eed98f..00000000 --- a/inst/App/sampleProjects/shinyDialInputOptimized/app.R +++ /dev/null @@ -1,23 +0,0 @@ -library(shiny) -source("widgetCntrl.R") - -ui<-fluidPage( - widgetCntrl(inputId='widget', wh=c(300,200) ), - textOutput('result'), - sliderInput("slider", label='degrees', min=0, max=180, step=1, value=0), - actionButton('setValueButton',label = 'Set theta') -) - -server<-function(input,output,session){ - output$result<-renderText(input$widget) - observeEvent(input$widget,{ - updateSliderInput(session, "slider", value=input$widget) - }) - observeEvent(input$setValueButton,{ - if(!identical(input$slider, input$widget)){ - updateWidgetCntrl(session, 'widget', value=input$slider) - } - }) -} - -shinyApp(ui=ui, server=server) diff --git a/inst/App/sampleProjects/shinyDialInputOptimized/aux/dnds/jstools.dnds b/inst/App/sampleProjects/shinyDialInputOptimized/aux/dnds/jstools.dnds deleted file mode 100644 index baf3ee98..00000000 --- a/inst/App/sampleProjects/shinyDialInputOptimized/aux/dnds/jstools.dnds +++ /dev/null @@ -1,450 +0,0 @@ ---- -title: "Dnd Snippet" -author: "Anonymous" -date: "TODAY" -output: dnd_snippet ---- - - -********************* - - -POPUP -``` -add mouse2pt function -``` -SNIPPET -``` -mouse2pt: function(id, x, y){ //method to convert mouse coord to svg coord - var thisSVG=document.querySelector("#" + id +" svg"); - var pt= thisSVG.createSVGPoint(); - pt.x = x; - pt.y = y; - return pt.matrixTransform(thisSVG.getScreenCTM().inverse()); -} -``` -SVGR -``` -library(svgR) -WH<-c(48,32) -ptR<-list( - x=matrix(0,2,0) -) -R<-WH[1]*.2 -CXY=WH*c(.3,.5) - - -svgR(wh=WH, - circle(cxy=CXY+c(-R,-R), r=R/4, fill='#00FFFF'), - circle(cxy=CXY+c(-R,+R), r=R/4, fill='#00FFFF'), - circle( - cxy=CXY, - r=R, - fill='#00FFFF' - ), - rect(xy=CXY-c(0,R), wh=c(.5,.6)*WH, fill='#00FFFF'), - line(xy1=CXY-c(0,R),xy2=CXY+c(0,R), stroke='black'), - line(xy1=CXY-c(R,0),xy2=CXY, stroke='black'), - #polygon(points=WH*c(c(.1,.5),c(.25,.2),c(.25,.8)), fill='#00FFFF'), - text(cxy=WH/2, "xy") -) -``` -********************* - -POPUP -``` -add mouse click -``` -SNIPPET -``` -clicked: function(ctrlId, evt ){ - ${0:0} -} -``` -SVGR -``` -library(svgR) -WH<-c(48,32) -ptR<-list( - x=matrix(0,2,0) -) -R<-WH[1]*.2 -CXY=WH*c(.3,.5) -svgR(wh=WH, stroke="#00FFFF", fill="none", - circle(cxy=CXY+c(-R,-R), r=R/4, fill='#00FFFF'), - circle(cxy=CXY+c(-R,+R), r=R/4, fill='#00FFFF'), - g( - polygon( - points=c(WH)*c( - c(.0,.0),c(.2,.5), c(.05,.3), c(.05,.6), - c(-.05,.6),c(-.05,.3), c(-.2,.5) - ), - stroke="#00FFFF" - ), - lapply(c(0,45,135,180), function(theta){ - line(xy1=c(.1,0)*WH, xy2=c(.3,0)*WH, stroke="#00FFFF", - transform=list(rotate=-theta) - ) - }), - transform=list( translate=WH*c(.6,.45), rotate=65) - ) -) -``` - -****************** -POPUP -``` -replace node -``` -SNIPPET -``` - var htm=data.${1,value}; //value - var node=jQuery.parseHTML( htm ); - ${0,(el)}.empty().append(node); -``` -SVGR -``` -library(svgR) -WH<-c(48,32) -ptR<-list( - x=matrix(0,2,0) -) -R<-.06*WH[1] -d<-list(M=WH*c(.2,.42), Q=WH*c(c(.2,.8),c(.5,.8))) - -svgR(wh=WH, stroke.width=2, stroke="#00FFFF", fill="none", - #circle(cxy=WH*c(.2,.2), fill="#00FFFF", r=R), - #circle(cxy=WH*c(.8,.2), fill="#00FFFF", r=R), - #rect(xy=WH*c(.16,.32), fill="#00FFFF", wh=c(.6,.16)*WH), - text(xy=WH*c(.16,.38),'html', stroke.width=1, fill="#00FFFF"), - circle(cxy=WH*(c(1,1)-c(.2,.2)), r=R), - path(d=d, stroke="#00FFFF", - marker.end=marker(viewBox=c(0, 0, 10, 10), refXY=c(1,5), stroke.width=1, fill="#00FFFF", - markerWidth=4, markerHeight=5, orient="auto", - path( d=c("M", 0, 0, "L", 9, 5, "L", 0, 9, "z") ) - ) - ) -) -``` -****************** -****************** -POPUP -``` -get attribute -``` -SNIPPET -``` - var attr = $(el).attr(`${1:data-Z}`); -``` -SVGR -``` -library(svgR) -WH<-c(48,32) -ptR<-list( - x=matrix(0,2,0) -) -R<-.06*WH[1] -d<-list(M=WH*c(.2,.42), Q=WH*c(c(.2,.8),c(.5,.8))) - -svgR(wh=WH, stroke.width=2, stroke="#00FFFF", fill="none", - text(xy=WH*c(.2,.38),'attr', stroke.width=1, fill="#00FFFF"), - path(d=d, stroke="#00FFFF", - marker.end=marker(viewBox=c(0, 0, 10, 10), refXY=c(1,5), stroke.width=1, fill="#00FFFF", - markerWidth=4, markerHeight=5, orient="auto", - path( d=c("M", 0, 0, "L", 9, 5, "L", 0, 9, "z") ) - ) - ) -) -``` -****************** -****************** -POPUP -``` -get element data -``` -SNIPPET -``` - var htm=data.${1,value}; //value - var node=jQuery.parseHTML( htm ); - ${0,(el)}.empty().append(node); -``` -SVGR -``` -library(svgR) -WH<-c(48,32) -ptR<-list( - x=matrix(0,2,0) -) -R<-.06*WH[1] -d<-list(M=WH*c(.8,.42), Q=WH*c(c(.8,.8),c(.2,.8))) - -svgR(wh=WH, #stroke.width=1, stroke="#00FFFF", fill="none", - polygon(points=WH*c(c(.05,.5), c(.15,.3),c(.15,.7)),fill='#00FFFF'), - rect(cxy=WH*c(.2,.5), wh=WH*c(.1,.1),fill="#00FFFF"), - lapply(1:5, function(i){ - ellipse( - cxy=c(.6, .8-i*.1)*WH, - rxy=c(.2,.1)*WH, - stroke='black', - fill='#00FFFF', - stroke='black', - stroke.width=.5 - ) - }) -) -``` -****************** - -****************** -POPUP -``` -set element data -``` -SNIPPET -``` - var htm=data.${1,value}; //value - var node=jQuery.parseHTML( htm ); - ${0,(el)}.empty().append(node); -``` -SVGR -``` -library(svgR) -WH<-c(48,32) -ptR<-list( - x=matrix(0,2,0) -) -R<-.06*WH[1] -d<-list(M=WH*c(.8,.85), Q=WH*c(c(.12,.85),c(.12,.52))) - -svgR(wh=WH, #stroke.width=1, stroke="#00FFFF", fill="none", - polygon(points=WH*c(c(.25,.5), c(.15,.3),c(.15,.7)),fill='#00FFFF'), - rect(cxy=WH*c(.1,.5), wh=WH*c(.1,.1),fill="#00FFFF"), - lapply(1:5, function(i){ - ellipse( - cxy=c(.6, .8-i*.1)*WH, - rxy=c(.2,.1)*WH, - stroke='black', - fill='#00FFFF', - stroke='black', - stroke.width=.5 - ) - }) -) -``` - -********************* - - -********************* - - -POPUP -``` -To string -``` -SNIPPET -``` -JSON.stringify(${1:obj}) -``` -SVGR -``` -library(svgR) -WH<-c(48,32) -ptR<-list( - x=matrix(0,2,0) -) -r=WH[2]/3 -lft=WH[1]/2-1.5*r -top<-WH[2]/2-r -bot<-WH[2]/2+r -svgR(wh=WH, - polygon(points=WH*c(c(.25,.5), c(.15,.3),c(.15,.7)),fill='#00FFFF'), - rect(cxy=WH*c(.1,.5), wh=WH*c(.1,.1),fill="#00FFFF"), - circle( - cxy=WH/2, - r=WH[2]/3, - stroke='none', - fill='#00FFFF' - ), - path( - d=list( - M=c(.4,.8)*WH, - C=c( c(.6,1.2),c(.9,.2), c(.8,.9))*WH - ), - stroke='#00FFFF', - stroke.width=1, - fill='none' - ), - g( - lapply(1:3, function(i){ - ellipse(cxy=WH*c(.5, .1), rxy=i*c(8,3), fill='none', stroke='#000000', stroke.width=.5) - }), - mask=mask(circle(cxy=WH/2, r=WH[2]/3), fill='white' ) - ), - g( - lapply(1:5, function(i){ - ellipse(cxy=WH*c(.7, .5), rxy=i*c(3,5), fill='none', stroke='#000000', stroke.width=.5) - }), - mask=mask( - circle(cxy=WH/2, r=WH[2]/3, fill='white'), - ellipse(cxy=WH*c(.5, .1), rxy=3*c(8,3), fill='black') - ) - ), - g( - lapply(1:5, function(i){ - ellipse(cxy=WH*c(.3, .3), rxy=i*c(3,5), fill='none', stroke='#000000', stroke.width=.5) - }), - mask=mask( - circle(cxy=WH/2, r=WH[2]/3, fill='white'), - ellipse(cxy=WH*c(.5, .1), rxy=3*c(8,3), fill='black'), - ellipse(cxy=WH*c(.7, .5), rxy=5*c(3,5), fill='black') - ) - ) -) -``` -********************* - - -POPUP -``` -From string -``` -SNIPPET -``` -JSON.parse(${1:obj}) -``` -SVGR -``` -library(svgR) -WH<-c(48,32) -ptR<-list( - x=matrix(0,2,0) -) -r=WH[2]/3 -lft=WH[1]/2-1.5*r -top<-WH[2]/2-r -bot<-WH[2]/2+r -svgR(wh=WH, - polygon(points=WH*c(c(.05,.5), c(.15,.3),c(.15,.7)),fill='#00FFFF'), - rect(cxy=WH*c(.2,.5), wh=WH*c(.1,.1),fill="#00FFFF"), - circle( - cxy=WH/2, - r=WH[2]/3, - stroke='none', - fill='#00FFFF' - ), - path( - d=list( - M=c(.4,.8)*WH, - C=c( c(.6,1.2),c(.9,.2), c(.8,.9))*WH - ), - stroke='#00FFFF', - stroke.width=1, - fill='none' - ), - g( - lapply(1:3, function(i){ - ellipse(cxy=WH*c(.5, .1), rxy=i*c(8,3), fill='none', stroke='#000000', stroke.width=.5) - }), - mask=mask(circle(cxy=WH/2, r=WH[2]/3), fill='white' ) - ), - g( - lapply(1:5, function(i){ - ellipse(cxy=WH*c(.7, .5), rxy=i*c(3,5), fill='none', stroke='#000000', stroke.width=.5) - }), - mask=mask( - circle(cxy=WH/2, r=WH[2]/3, fill='white'), - ellipse(cxy=WH*c(.5, .1), rxy=3*c(8,3), fill='black') - ) - ), - g( - lapply(1:5, function(i){ - ellipse(cxy=WH*c(.3, .3), rxy=i*c(3,5), fill='none', stroke='#000000', stroke.width=.5) - }), - mask=mask( - circle(cxy=WH/2, r=WH[2]/3, fill='white'), - ellipse(cxy=WH*c(.5, .1), rxy=3*c(8,3), fill='black'), - ellipse(cxy=WH*c(.7, .5), rxy=5*c(3,5), fill='black') - ) - ) -) -``` - -********************* - - -POPUP -``` -LOG -``` -SNIPPET -``` -console.log(${1:'text '+} ${0:value}); -``` -SVGR -``` -library(svgR) -WH<-c(48,32) -ptR<-list( - x=matrix(0,2,0) -) -svgR(wh=WH, - rect(xy=c(.3,.35)*WH, wh=WH*c(.5,.3), fill='#00FFFF'), - ellipse( - cxy=c(.8,.5)*WH, - rxy=c(.05,.15)*WH, - fill='#00FFFF' - ), - ellipse( - cxy=c(.3,.5)*WH, - rxy=c(.05,.15)*WH, - fill='#00FFFF', - stroke='black', - stroke.width=.5 - ), - ellipse( - cxy=c(.3,.5)*WH, - rxy=.5*c(.05,.15)*WH, - fill='#00FFFF', - stroke='black', - stroke.width=.5 - ), - polygon(points=c( c(.5,.35), c(.6,.4), c(.7,.2), c(.6,.15))*WH, - fill='#00FFFF') -) -``` -********************* - -POPUP -``` -Trigger -``` -SNIPPET -``` -${1:$(el)}.trigger(${0:"change"}); -``` -SVGR -``` -library(svgR) -WH<-c(48,32) -ptR<-list( - x=matrix(0,2,0) -) -X=c(.2,.4,.6,.8) -D<-list( - M=c(.2,.2), - Q=c( ) -) -svgR(wh=WH, #stroke.width=1, stroke="#00FFFF", fill="none", - path(d=c("M",c(10,5), "Q", c(5,20), c(25,25) , "T", c(40,5)) , fill='#00FFFF'), - path(d=c("M",c(12,8), "Q", c(8,20), c(25,22) , "T", c(36,8)) , fill='black'), - path(d=c( "M", c(24,8), "C", c(22,10), c(30,10), c( 18,18), "Q" , c(30,15), c(28,10), c(32,10), c(32,8)),fill='#00FFFF') - - -) -``` -****************** - - - - diff --git a/inst/App/sampleProjects/shinyDialInputOptimized/test.SVG b/inst/App/sampleProjects/shinyDialInputOptimized/test.SVG deleted file mode 100644 index 466e03b0..00000000 --- a/inst/App/sampleProjects/shinyDialInputOptimized/test.SVG +++ /dev/null @@ -1,11 +0,0 @@ - - - - - - - diff --git a/inst/App/sampleProjects/shinyDialInputOptimized/widget.pprj b/inst/App/sampleProjects/shinyDialInputOptimized/widget.pprj deleted file mode 100644 index 273b901a..00000000 --- a/inst/App/sampleProjects/shinyDialInputOptimized/widget.pprj +++ /dev/null @@ -1 +0,0 @@ -{"pathToProj":["~/AA/widget"],"projName":["widget.pprj"],"projType":[[[[[["generic"]]]]]]} diff --git a/inst/App/sampleProjects/shinyDialInputOptimized/widgetCntrl.R b/inst/App/sampleProjects/shinyDialInputOptimized/widgetCntrl.R deleted file mode 100644 index 225399c4..00000000 --- a/inst/App/sampleProjects/shinyDialInputOptimized/widgetCntrl.R +++ /dev/null @@ -1,45 +0,0 @@ -library(shiny) -library(svgR) - -widgetSvgCntrl<-function(args){ - source('widget_svg.R', local=T)$value -} - -newWidgetCntrl<-function(WH, theta0, CXY, R, CMD ){ - svg<-widgetSvgCntrl(list(WH=WH, theta0=theta0, CXY=CXY, R=R, CMD=CMD)) - HTML(as.character(svg)) -} - -widgetCntrl<-function(inputId, wh, theta0=0){ - cxy<-c(.5,.9)*wh - r<-.4*wh[1] -# SCRIPT<-' -# function clicked(evt, ctrlId){ -# // compute theta (in radians) -# var theta = widgetCntrlBinding.mouse2theta(ctrlId, evt.clientX, evt.clientY); -# widgetCntrlBinding.updateNeedle(ctrlId,theta ); -# //update value -# theta=Math.round((180 *theta) / Math.PI ); -# widgetCntrlBinding.setValue("#" + ctrlId, theta); -# }' - CMD=sprintf('widgetCntrlBinding.clicked("%s", evt)',inputId) - tagList( - singleton(tags$head(tags$script(src = "widget.js"))), - div( id=inputId, - class="widgetCntrl", # - "data-theta"=theta0, # customize for initialization - 'data-x'=cxy[1], - 'data-y'=cxy[2], - 'data-r'=r, - newWidgetCntrl(WH=wh, theta0=theta0, CXY=cxy, R=r, CMD=CMD) - ) - ) -} - -updateWidgetCntrl<-function(session, inputId, value=NULL){ - mssg<-list(value=value) - if(length(mssg)>0){ - session$sendInputMessage(inputId, mssg) - } -} - diff --git a/inst/App/sampleProjects/shinyDialInputOptimized/widget_svg.R b/inst/App/sampleProjects/shinyDialInputOptimized/widget_svg.R deleted file mode 100644 index 293660a5..00000000 --- a/inst/App/sampleProjects/shinyDialInputOptimized/widget_svg.R +++ /dev/null @@ -1,74 +0,0 @@ -library(svgR) -library(tidyverse) - - -WH<-c(400,200) -theta0<-45 -CXY<-c(.5,.9)*WH -R<-.4*WH[1] -CMD<-"" - -if(exists("argv")){ - list2env(argv, envir = environment()) -} - - -theta2pos<-function(theta, cxy=CXY, r=R){ - theta<-pi*theta/180 - cxy+r*c(cos(theta),-sin(theta)) -} - -pos2theta<-function(pos, cxy=CXY){ - pos<-pos-cxy - if(abs(pos[1])>.0001){ - theta<-pi/2 - } else { - theta<-atan(-pos[2]/pos[1]) - } - 180*(theta)/pi -} - -descriptor<-function(theta, cxy=CXY, r=R){ - d=list( - M=CXY, - L=theta2pos(0), - A=c( c(R,R), 180,0,0,theta2pos(theta)), - Z=1 - ) -} - -descriptor2<-function(theta, cxy=CXY, r=R){ - d=list( - M=theta2pos(0), - A=c( c(R,R), 180,0,0,theta2pos(theta)) - ) -} - - -tmp<-as.character(svgR(wh=WH, - #your custom code goes here - - - path( - d=descriptor(180), - stroke='#0000FF', - stroke.width=2, - fill='none' - ), - path( - d=descriptor(180), - stroke='#AA00FF', - stroke.width=20, - fill='none', - onClick=CMD - ), - line( xy1=CXY, xy2=theta2pos(theta0), stroke='red', stroke.width=5), - circle( cxy=theta2pos(theta0), r=10, fill='lightblue'), - circle( cxy=CXY, r=10, fill='lightblue') -)) - -cat(tmp) - -tmp - - diff --git a/inst/App/sampleProjects/shinyDialInputOptimized/www/widget.js b/inst/App/sampleProjects/shinyDialInputOptimized/www/widget.js deleted file mode 100644 index d292659c..00000000 --- a/inst/App/sampleProjects/shinyDialInputOptimized/www/widget.js +++ /dev/null @@ -1,84 +0,0 @@ -// Javascript -//BEGIN: INPUT BINDING -var widgetCntrlBinding = new Shiny.InputBinding(); -$.extend(widgetCntrlBinding, { - find: function(scope) { - console.log('find'); - return $(scope).find(".widgetCntrl"); - }, - initialize: function(el){ - // Initialize any data values here - $(el).data("theta", $(el).attr("data-theta")); - $(el).data("R", $(el).attr("data-r")); - $(el).data('CXY',{ - x:Number($(el).attr("data-x")), - y:Number($(el).attr("data-y")) - }); - }, - getValue: function(el) {// used to return the value of the input control - return $(el).data('theta'); //we return only theta (in degrees) - }, - setValue: function(el, value) { // used for updating input control - // theta value is assumed to be in degrees - $(el).data('theta',value); - $(el).trigger("change"); - }, - subscribe: function(el, callback) { - // notify server whenever change - $(el).on("change.widgetCntrlBinding", function(e) { - callback(); - }); - }, - unsubscribe: function(el) { - $(el).off(".widgetCntrlBinding"); - }, - receiveMessage: function(el, data) { //called by server when updating - if(!!data.value){ - var id=$(el).attr('id'); - var theta=data.value; //assumed to be in degrees - this.updateNeedle(id, (Math.PI*theta)/180); //adjust image - this.setValue($(el), data.value); //record value - } - }, - mouse2pt: function(id, x, y){ //method to convert mouse coord to svg coord - var thisSVG=document.querySelector("#" + id +" svg"); - var pt= thisSVG.createSVGPoint(); - pt.x = x; - pt.y = y; - return pt.matrixTransform(thisSVG.getScreenCTM().inverse()); - }, - getCXY: function(id){ - return $("#"+id).data('CXY'); - }, - pts2theta:function(q, p){ //compute theta - return 0.5*Math.PI + Math.atan( (p.x-q.x)/(p.y-q.y) ); - }, - mouse2theta: function(id, x, y){ - var p=this.mouse2pt(id, x, y); - var q= $("#"+id).data('CXY'); - return this.pts2theta(q, p); - }, - polar2xy: function(q, theta, r){ - return { x:q.x + r*Math.cos(theta), y:q.y - r*Math.sin(theta)}; - }, - updateNeedle:function(id, theta){ // assumes theta in radians - var el='#'+id; - var r=$(el).data('R'); - var q= $(el).data('CXY'); - var p=this.polar2xy(q,theta,r); - $(el + " svg line").attr({"x2":p.x, "y2":p.y}); - $(el + " svg circle:first").attr({"cx":p.x, "cy":p.y}); - }, - clicked: function(ctrlId, evt ){ - // compute theta (in radians) - var theta = this.mouse2theta(ctrlId, evt.clientX, evt.clientY); - this.updateNeedle(ctrlId,theta ); - //update value - theta=Math.round((180 *theta) / Math.PI ); - this.setValue("#" + ctrlId, theta); - } -}); - -// register input binding -Shiny.inputBindings.register(widgetCntrlBinding); - diff --git a/inst/App/sampleProjects/shinyQuibitCtrl/.workspace/PTR-TABID1b8a789c513.rda b/inst/App/sampleProjects/shinyQuibitCtrl/.workspace/PTR-TABID1b8a789c513.rda deleted file mode 100644 index a1171351..00000000 Binary files a/inst/App/sampleProjects/shinyQuibitCtrl/.workspace/PTR-TABID1b8a789c513.rda and /dev/null differ diff --git a/inst/App/sampleProjects/shinyQuibitCtrl/.workspace/PTR-TABID41cd6cdad2c7.rda b/inst/App/sampleProjects/shinyQuibitCtrl/.workspace/PTR-TABID41cd6cdad2c7.rda deleted file mode 100644 index 4556a66c..00000000 Binary files a/inst/App/sampleProjects/shinyQuibitCtrl/.workspace/PTR-TABID41cd6cdad2c7.rda and /dev/null differ diff --git a/inst/App/sampleProjects/shinyQuibitCtrl/.workspace/PTR-TABID704c2e20c007.rda b/inst/App/sampleProjects/shinyQuibitCtrl/.workspace/PTR-TABID704c2e20c007.rda deleted file mode 100644 index b240f0e5..00000000 Binary files a/inst/App/sampleProjects/shinyQuibitCtrl/.workspace/PTR-TABID704c2e20c007.rda and /dev/null differ diff --git a/inst/App/sampleProjects/shinyQuibitCtrl/.workspace/PTR-TABIDa9527235bba.rda b/inst/App/sampleProjects/shinyQuibitCtrl/.workspace/PTR-TABIDa9527235bba.rda deleted file mode 100644 index a661cf38..00000000 Binary files a/inst/App/sampleProjects/shinyQuibitCtrl/.workspace/PTR-TABIDa9527235bba.rda and /dev/null differ diff --git a/inst/App/sampleProjects/shinyQuibitCtrl/.workspace/currentTab.rda b/inst/App/sampleProjects/shinyQuibitCtrl/.workspace/currentTab.rda deleted file mode 100644 index 9b69586b..00000000 Binary files a/inst/App/sampleProjects/shinyQuibitCtrl/.workspace/currentTab.rda and /dev/null differ diff --git a/inst/App/sampleProjects/shinyQuibitCtrl/.workspace/loadedDnippets.rda b/inst/App/sampleProjects/shinyQuibitCtrl/.workspace/loadedDnippets.rda deleted file mode 100644 index bcdafe72..00000000 Binary files a/inst/App/sampleProjects/shinyQuibitCtrl/.workspace/loadedDnippets.rda and /dev/null differ diff --git a/inst/App/sampleProjects/shinyQuibitCtrl/app.R b/inst/App/sampleProjects/shinyQuibitCtrl/app.R deleted file mode 100644 index 79fe9595..00000000 --- a/inst/App/sampleProjects/shinyQuibitCtrl/app.R +++ /dev/null @@ -1,39 +0,0 @@ -library(shiny) -source("shinyInputCntrl.R") - -ui<-fluidPage( - shinyInputCntrl(inputId='myshinyInput', wh=c(400,200), Z=c(2-2i, 2+2i) ), - h3('current Value'), - textOutput('currentValue'), - textInput(inputId='updateValue','update value', ''), - actionButton('updateButton', label='press to update value') -) - -server<-function(input,output,session){ - output$currentValue<-renderText( - paste('c(', paste(as.character(round(input$myshinyInput, digits=2)), collapse=", "), ')') - ) - - observeEvent(input$updateButton,{ - value<-input$updateValue - print('update button pressed') - tryCatch({ - - value<-eval(parse(text=value)) - - if(length(value)!=2 || class(value)!='complex'){ - stop('invalid input') - } - - updateShinyInputCntrl(session, 'myshinyInput', wh=c(400,200), Z=value) - }, - error=function(e){ - # do nothing , record error - print('error') - }) - } - - ) -} - -shinyApp(ui=ui, server=server) diff --git a/inst/App/sampleProjects/shinyQuibitCtrl/aux/dnds/jstools.dnds b/inst/App/sampleProjects/shinyQuibitCtrl/aux/dnds/jstools.dnds deleted file mode 100644 index baf3ee98..00000000 --- a/inst/App/sampleProjects/shinyQuibitCtrl/aux/dnds/jstools.dnds +++ /dev/null @@ -1,450 +0,0 @@ ---- -title: "Dnd Snippet" -author: "Anonymous" -date: "TODAY" -output: dnd_snippet ---- - - -********************* - - -POPUP -``` -add mouse2pt function -``` -SNIPPET -``` -mouse2pt: function(id, x, y){ //method to convert mouse coord to svg coord - var thisSVG=document.querySelector("#" + id +" svg"); - var pt= thisSVG.createSVGPoint(); - pt.x = x; - pt.y = y; - return pt.matrixTransform(thisSVG.getScreenCTM().inverse()); -} -``` -SVGR -``` -library(svgR) -WH<-c(48,32) -ptR<-list( - x=matrix(0,2,0) -) -R<-WH[1]*.2 -CXY=WH*c(.3,.5) - - -svgR(wh=WH, - circle(cxy=CXY+c(-R,-R), r=R/4, fill='#00FFFF'), - circle(cxy=CXY+c(-R,+R), r=R/4, fill='#00FFFF'), - circle( - cxy=CXY, - r=R, - fill='#00FFFF' - ), - rect(xy=CXY-c(0,R), wh=c(.5,.6)*WH, fill='#00FFFF'), - line(xy1=CXY-c(0,R),xy2=CXY+c(0,R), stroke='black'), - line(xy1=CXY-c(R,0),xy2=CXY, stroke='black'), - #polygon(points=WH*c(c(.1,.5),c(.25,.2),c(.25,.8)), fill='#00FFFF'), - text(cxy=WH/2, "xy") -) -``` -********************* - -POPUP -``` -add mouse click -``` -SNIPPET -``` -clicked: function(ctrlId, evt ){ - ${0:0} -} -``` -SVGR -``` -library(svgR) -WH<-c(48,32) -ptR<-list( - x=matrix(0,2,0) -) -R<-WH[1]*.2 -CXY=WH*c(.3,.5) -svgR(wh=WH, stroke="#00FFFF", fill="none", - circle(cxy=CXY+c(-R,-R), r=R/4, fill='#00FFFF'), - circle(cxy=CXY+c(-R,+R), r=R/4, fill='#00FFFF'), - g( - polygon( - points=c(WH)*c( - c(.0,.0),c(.2,.5), c(.05,.3), c(.05,.6), - c(-.05,.6),c(-.05,.3), c(-.2,.5) - ), - stroke="#00FFFF" - ), - lapply(c(0,45,135,180), function(theta){ - line(xy1=c(.1,0)*WH, xy2=c(.3,0)*WH, stroke="#00FFFF", - transform=list(rotate=-theta) - ) - }), - transform=list( translate=WH*c(.6,.45), rotate=65) - ) -) -``` - -****************** -POPUP -``` -replace node -``` -SNIPPET -``` - var htm=data.${1,value}; //value - var node=jQuery.parseHTML( htm ); - ${0,(el)}.empty().append(node); -``` -SVGR -``` -library(svgR) -WH<-c(48,32) -ptR<-list( - x=matrix(0,2,0) -) -R<-.06*WH[1] -d<-list(M=WH*c(.2,.42), Q=WH*c(c(.2,.8),c(.5,.8))) - -svgR(wh=WH, stroke.width=2, stroke="#00FFFF", fill="none", - #circle(cxy=WH*c(.2,.2), fill="#00FFFF", r=R), - #circle(cxy=WH*c(.8,.2), fill="#00FFFF", r=R), - #rect(xy=WH*c(.16,.32), fill="#00FFFF", wh=c(.6,.16)*WH), - text(xy=WH*c(.16,.38),'html', stroke.width=1, fill="#00FFFF"), - circle(cxy=WH*(c(1,1)-c(.2,.2)), r=R), - path(d=d, stroke="#00FFFF", - marker.end=marker(viewBox=c(0, 0, 10, 10), refXY=c(1,5), stroke.width=1, fill="#00FFFF", - markerWidth=4, markerHeight=5, orient="auto", - path( d=c("M", 0, 0, "L", 9, 5, "L", 0, 9, "z") ) - ) - ) -) -``` -****************** -****************** -POPUP -``` -get attribute -``` -SNIPPET -``` - var attr = $(el).attr(`${1:data-Z}`); -``` -SVGR -``` -library(svgR) -WH<-c(48,32) -ptR<-list( - x=matrix(0,2,0) -) -R<-.06*WH[1] -d<-list(M=WH*c(.2,.42), Q=WH*c(c(.2,.8),c(.5,.8))) - -svgR(wh=WH, stroke.width=2, stroke="#00FFFF", fill="none", - text(xy=WH*c(.2,.38),'attr', stroke.width=1, fill="#00FFFF"), - path(d=d, stroke="#00FFFF", - marker.end=marker(viewBox=c(0, 0, 10, 10), refXY=c(1,5), stroke.width=1, fill="#00FFFF", - markerWidth=4, markerHeight=5, orient="auto", - path( d=c("M", 0, 0, "L", 9, 5, "L", 0, 9, "z") ) - ) - ) -) -``` -****************** -****************** -POPUP -``` -get element data -``` -SNIPPET -``` - var htm=data.${1,value}; //value - var node=jQuery.parseHTML( htm ); - ${0,(el)}.empty().append(node); -``` -SVGR -``` -library(svgR) -WH<-c(48,32) -ptR<-list( - x=matrix(0,2,0) -) -R<-.06*WH[1] -d<-list(M=WH*c(.8,.42), Q=WH*c(c(.8,.8),c(.2,.8))) - -svgR(wh=WH, #stroke.width=1, stroke="#00FFFF", fill="none", - polygon(points=WH*c(c(.05,.5), c(.15,.3),c(.15,.7)),fill='#00FFFF'), - rect(cxy=WH*c(.2,.5), wh=WH*c(.1,.1),fill="#00FFFF"), - lapply(1:5, function(i){ - ellipse( - cxy=c(.6, .8-i*.1)*WH, - rxy=c(.2,.1)*WH, - stroke='black', - fill='#00FFFF', - stroke='black', - stroke.width=.5 - ) - }) -) -``` -****************** - -****************** -POPUP -``` -set element data -``` -SNIPPET -``` - var htm=data.${1,value}; //value - var node=jQuery.parseHTML( htm ); - ${0,(el)}.empty().append(node); -``` -SVGR -``` -library(svgR) -WH<-c(48,32) -ptR<-list( - x=matrix(0,2,0) -) -R<-.06*WH[1] -d<-list(M=WH*c(.8,.85), Q=WH*c(c(.12,.85),c(.12,.52))) - -svgR(wh=WH, #stroke.width=1, stroke="#00FFFF", fill="none", - polygon(points=WH*c(c(.25,.5), c(.15,.3),c(.15,.7)),fill='#00FFFF'), - rect(cxy=WH*c(.1,.5), wh=WH*c(.1,.1),fill="#00FFFF"), - lapply(1:5, function(i){ - ellipse( - cxy=c(.6, .8-i*.1)*WH, - rxy=c(.2,.1)*WH, - stroke='black', - fill='#00FFFF', - stroke='black', - stroke.width=.5 - ) - }) -) -``` - -********************* - - -********************* - - -POPUP -``` -To string -``` -SNIPPET -``` -JSON.stringify(${1:obj}) -``` -SVGR -``` -library(svgR) -WH<-c(48,32) -ptR<-list( - x=matrix(0,2,0) -) -r=WH[2]/3 -lft=WH[1]/2-1.5*r -top<-WH[2]/2-r -bot<-WH[2]/2+r -svgR(wh=WH, - polygon(points=WH*c(c(.25,.5), c(.15,.3),c(.15,.7)),fill='#00FFFF'), - rect(cxy=WH*c(.1,.5), wh=WH*c(.1,.1),fill="#00FFFF"), - circle( - cxy=WH/2, - r=WH[2]/3, - stroke='none', - fill='#00FFFF' - ), - path( - d=list( - M=c(.4,.8)*WH, - C=c( c(.6,1.2),c(.9,.2), c(.8,.9))*WH - ), - stroke='#00FFFF', - stroke.width=1, - fill='none' - ), - g( - lapply(1:3, function(i){ - ellipse(cxy=WH*c(.5, .1), rxy=i*c(8,3), fill='none', stroke='#000000', stroke.width=.5) - }), - mask=mask(circle(cxy=WH/2, r=WH[2]/3), fill='white' ) - ), - g( - lapply(1:5, function(i){ - ellipse(cxy=WH*c(.7, .5), rxy=i*c(3,5), fill='none', stroke='#000000', stroke.width=.5) - }), - mask=mask( - circle(cxy=WH/2, r=WH[2]/3, fill='white'), - ellipse(cxy=WH*c(.5, .1), rxy=3*c(8,3), fill='black') - ) - ), - g( - lapply(1:5, function(i){ - ellipse(cxy=WH*c(.3, .3), rxy=i*c(3,5), fill='none', stroke='#000000', stroke.width=.5) - }), - mask=mask( - circle(cxy=WH/2, r=WH[2]/3, fill='white'), - ellipse(cxy=WH*c(.5, .1), rxy=3*c(8,3), fill='black'), - ellipse(cxy=WH*c(.7, .5), rxy=5*c(3,5), fill='black') - ) - ) -) -``` -********************* - - -POPUP -``` -From string -``` -SNIPPET -``` -JSON.parse(${1:obj}) -``` -SVGR -``` -library(svgR) -WH<-c(48,32) -ptR<-list( - x=matrix(0,2,0) -) -r=WH[2]/3 -lft=WH[1]/2-1.5*r -top<-WH[2]/2-r -bot<-WH[2]/2+r -svgR(wh=WH, - polygon(points=WH*c(c(.05,.5), c(.15,.3),c(.15,.7)),fill='#00FFFF'), - rect(cxy=WH*c(.2,.5), wh=WH*c(.1,.1),fill="#00FFFF"), - circle( - cxy=WH/2, - r=WH[2]/3, - stroke='none', - fill='#00FFFF' - ), - path( - d=list( - M=c(.4,.8)*WH, - C=c( c(.6,1.2),c(.9,.2), c(.8,.9))*WH - ), - stroke='#00FFFF', - stroke.width=1, - fill='none' - ), - g( - lapply(1:3, function(i){ - ellipse(cxy=WH*c(.5, .1), rxy=i*c(8,3), fill='none', stroke='#000000', stroke.width=.5) - }), - mask=mask(circle(cxy=WH/2, r=WH[2]/3), fill='white' ) - ), - g( - lapply(1:5, function(i){ - ellipse(cxy=WH*c(.7, .5), rxy=i*c(3,5), fill='none', stroke='#000000', stroke.width=.5) - }), - mask=mask( - circle(cxy=WH/2, r=WH[2]/3, fill='white'), - ellipse(cxy=WH*c(.5, .1), rxy=3*c(8,3), fill='black') - ) - ), - g( - lapply(1:5, function(i){ - ellipse(cxy=WH*c(.3, .3), rxy=i*c(3,5), fill='none', stroke='#000000', stroke.width=.5) - }), - mask=mask( - circle(cxy=WH/2, r=WH[2]/3, fill='white'), - ellipse(cxy=WH*c(.5, .1), rxy=3*c(8,3), fill='black'), - ellipse(cxy=WH*c(.7, .5), rxy=5*c(3,5), fill='black') - ) - ) -) -``` - -********************* - - -POPUP -``` -LOG -``` -SNIPPET -``` -console.log(${1:'text '+} ${0:value}); -``` -SVGR -``` -library(svgR) -WH<-c(48,32) -ptR<-list( - x=matrix(0,2,0) -) -svgR(wh=WH, - rect(xy=c(.3,.35)*WH, wh=WH*c(.5,.3), fill='#00FFFF'), - ellipse( - cxy=c(.8,.5)*WH, - rxy=c(.05,.15)*WH, - fill='#00FFFF' - ), - ellipse( - cxy=c(.3,.5)*WH, - rxy=c(.05,.15)*WH, - fill='#00FFFF', - stroke='black', - stroke.width=.5 - ), - ellipse( - cxy=c(.3,.5)*WH, - rxy=.5*c(.05,.15)*WH, - fill='#00FFFF', - stroke='black', - stroke.width=.5 - ), - polygon(points=c( c(.5,.35), c(.6,.4), c(.7,.2), c(.6,.15))*WH, - fill='#00FFFF') -) -``` -********************* - -POPUP -``` -Trigger -``` -SNIPPET -``` -${1:$(el)}.trigger(${0:"change"}); -``` -SVGR -``` -library(svgR) -WH<-c(48,32) -ptR<-list( - x=matrix(0,2,0) -) -X=c(.2,.4,.6,.8) -D<-list( - M=c(.2,.2), - Q=c( ) -) -svgR(wh=WH, #stroke.width=1, stroke="#00FFFF", fill="none", - path(d=c("M",c(10,5), "Q", c(5,20), c(25,25) , "T", c(40,5)) , fill='#00FFFF'), - path(d=c("M",c(12,8), "Q", c(8,20), c(25,22) , "T", c(36,8)) , fill='black'), - path(d=c( "M", c(24,8), "C", c(22,10), c(30,10), c( 18,18), "Q" , c(30,15), c(28,10), c(32,10), c(32,8)),fill='#00FFFF') - - -) -``` -****************** - - - - diff --git a/inst/App/sampleProjects/shinyQuibitCtrl/aux/dnds/sampleShapes.dnds b/inst/App/sampleProjects/shinyQuibitCtrl/aux/dnds/sampleShapes.dnds deleted file mode 100644 index 0034e180..00000000 --- a/inst/App/sampleProjects/shinyQuibitCtrl/aux/dnds/sampleShapes.dnds +++ /dev/null @@ -1,527 +0,0 @@ ---- -title: "Samples" -author: "Anonymous" -date: "TODAY" -output: dnd_snippet ---- - -- Individual drippets are seperate by lines consisting of three or more stars (*) -- Each drippet consists of 3 entries, with each entry having a title and a value (block) -- The title consists of a single line followed by a colon (:) -- titles are *Hint:*, *SNIPPET*, *SVGR* - - The values are blocks defined by 3 backtics *````* - - Two drippets are shown below to help you get started - -********************* - - -POPUP -``` -Sample Circle -``` -SNIPPET -``` -circle( - cxy=${1:WH/2}, - r=${2:WH[2]/3}, - stroke='black', - fill=${3:'none'} -)${0:} -``` -SVGR -``` -library(svgR) -WH<-c(48,32) -ptR<-list( - x=matrix(0,2,0) -) -svgR(wh=WH, -#your custom code goes here - circle( - cxy=WH/2, - r=WH[2]/3, - stroke='#00FFFF', - stroke.width=2, - fill='none' - ) -) -``` -********************* - - - -POPUP -``` -Sample Ellipse -``` -SNIPPET -``` -ellipse( - cxy=${1:WH/2}, - rxy=${2:c(.4,.3)*WH}, - stroke=${3:'black'}, - fill=${4:'none'} -)${0:} -``` -SVGR -``` -library(svgR) -WH<-c(48,32) -ptR<-list( - x=matrix(0,2,0) -) -svgR(wh=WH, -#your custom code goes here - ellipse( - cxy=WH/2, - rxy=c(.3,.2)*WH, - stroke='#00FFFF', - stroke.width=2, - fill='none' - ) -) -``` -********************* - -********************* - - - -POPUP -``` -Sample Rectangle -``` -SNIPPET -``` -rect( - xy=${1:WH/2}, - wh=${2:c(.47,.3)*WH}, - stroke='black', - fill=${3:'none'} -)${0:} -``` -SVGR -``` -library(svgR) -WH<-c(48,32) -ptR<-list( - x=matrix(0,2,0) -) -svgR(wh=WH, - line(xy1=c(.5,0)*WH, xy2=c(.5,1)*WH, stroke.dasharray=2, stroke="#00FFFF"), - line(xy1=c(0,.5)*WH, xy2=c(1,.5)*WH, stroke.dasharray=2, stroke="#00FFFF"), - rect( - xy=WH/2, - wh=c(.4,.2)*WH, - stroke='#00FFFF', - stroke.width=2, - fill='none' - ) -) -``` -********************* - - - - -POPUP -``` -Sample Centered Rectangle -``` -SNIPPET -``` -rect( - cxy=${1:WH/2}, - wh=${2:c(.47,.3)*WH}, - stroke='black', - fill=${3:'none'} -)${0:} -``` -SVGR -``` -library(svgR) -WH<-c(48,32) -ptR<-list( - x=matrix(0,2,0) -) -svgR(wh=WH, - line(xy1=c(.5,0)*WH, xy2=c(.5,1)*WH, stroke.dasharray=2, stroke="#00FFFF"), - line(xy1=c(0,.5)*WH, xy2=c(1,.5)*WH, stroke.dasharray=2, stroke="#00FFFF"), - rect( - cxy=WH/2, - wh=c(.4,.2)*WH, - stroke='#00FFFF', - stroke.width=2, - fill='none' - ) -) -``` -********************* -********************* -POPUP -``` -Sample Line Segment -``` -SNIPPET -``` -line( - xy1=${1:c(0,0)}, - xy2=${2:WH}, - stroke=${3:'black'} -)${0:} -``` -SVGR -``` -library(svgR) -WH<-c(48,32) -ptR<-list( - x=matrix(0,2,0) -) -svgR(wh=WH, - line( - xy1=c(.2,0.8)*WH, - xy2=c(.8,0.2)*WH, - stroke='#00FFFF', - stroke.width=2 - ) -) -``` -********************* -********************* -POPUP -``` -Sample PolyLine (Connected Line Segments) -``` -SNIPPET -``` -polyline( - points=${1:WH*matrix(c(.25,.25,.5,.5,.75,.25),2)}, - stroke=${2:'black'}, - stroke.width=${2:1}, - fill=${3:'none'} -)${0:} -``` -SVGR -``` -library(svgR) -WH<-c(48,32) -ptR<-list( - x=matrix(0,2,0) -) -svgR(wh=WH, - polyline( - points=WH*matrix(c(.25,.25,.5,.8,.75,.25),2), - stroke.width=2, - stroke='#00FFFF', - fill='none' - ) -) -``` -********************* -********************* -POPUP -``` -Sample Polygon -``` -SNIPPET -``` -polygon( - points=${1:WH*matrix(c(.25,.75,.5,.5,.75,.75),2)}, - stroke=${2:'black'}, - stroke.width=${2:1}, - fill=${3:'none'} -)${0:} -``` -SVGR -``` -library(svgR) -WH<-c(48,32) -ptR<-list( - x=matrix(0,2,0) -) -svgR(wh=WH, - polygon( - points=WH*matrix(c(.25,.75,.5,.25,.75,.75),2), - stroke='#00FFFF', - stroke.width=2, - fill='none' - ) -) -``` -********************* -********************* -POPUP -``` -Sample Text -``` -SNIPPET -``` -text( - ${1:'hello world'}, - xy=${2:WH/2}, - stroke=${3:'black'}, - font.size=${4:36}, - fill=${5:'none'} -)${0:} -``` -SVGR -``` -library(svgR) -WH<-c(48,32) -ptR<-list( - x=matrix(0,2,0) -) -svgR(wh=WH, - line(xy1=c(.5,0)*WH, xy2=c(.5,1)*WH, stroke.dasharray=2, stroke="#00FFFF"), - line(xy1=c(0,.5)*WH, xy2=c(1,.5)*WH, stroke.dasharray=2, stroke="#00FFFF"), - text( - 'Text', - xy=WH/2, - stroke='#00FFFF', - font.size=10, - fill='#00FFFF' - ) -) -``` -********************* -********************* -POPUP -``` -Sample Text -``` -SNIPPET -``` - text( - ${1:'hello world'}, - cxy=${2:WH/2}, - stroke=${3:'black'}, - font.size=${4:36}, - fill=${5:'none'} - )${0:} -``` -SVGR -``` -library(svgR) -WH<-c(48,32) -ptR<-list( - x=matrix(0,2,0) -) -svgR(wh=WH, - line(xy1=c(.5,0)*WH, xy2=c(.5,1)*WH, stroke.dasharray=2, stroke="#00FFFF"), - line(xy1=c(0,.5)*WH, xy2=c(1,.5)*WH, stroke.dasharray=2, stroke="#00FFFF"), - text( - 'Text', - cxy=WH/2, - stroke='#00FFFF', - font.size=10, - fill='#00FFFF' - ) -) -``` -********************* -****************** -POPUP -``` -Sample Arc -``` -SNIPPET -``` - path( - d=list( - M=${1:c(.5,.2)*WH}, - A=${2:c(2.3*WH, 180,1,0,c(.8,.5)*WH)} - ), - stroke=${3:'#0000FF'}, - stroke.width=${4:2}, - fill=${5:'none'} - )${0:} -``` -SVGR -``` -library(svgR) -WH<-c(48,32) -# Defined by mouse: edit with care! -ptR<-list( - x=tribble( - ~points, - matrix(NA,2,0) - ) -) -svgR(wh=WH, - path( - d=list( - M=c(.5,.2)*WH, - A=c(.3*WH, 180,1,0,c(.8,.5)*WH) - ), - stroke='#00FFFF', - stroke.width=2, - fill='none' - ) -) -``` -*********************** -****************** -POPUP -``` -Sample Quadratic Bezier -``` -SNIPPET -``` -path( - d=list( - ${1:M=c(.2,.2)*WH,} - Q=${2:c( c(.5,1.5),c(.8,.2))*WH} - ), - stroke=${3:'#000FF'}, - stroke.width=${4:1}, - fill=${5:'none'} -)${0:} -``` -SVGR -``` -library(svgR) -WH<-c(48,32) -# Defined by mouse: edit with care! -ptR<-list( - x=tribble( - ~points, - matrix(NA,2,0) - ) -) -svgR(wh=WH, - path( - d=list( - M=c(.2,.2)*WH, - Q=c( c(.5,1.5)*WH,c(.8,.2)*WH) - ), - stroke='#00FFFF', - stroke.width=2, - fill='none' - ) -) -``` -*********************** -****************** -POPUP -``` -Sample Extended Quadratic Bezier -``` -SNIPPET -``` -path( - d=list( - ${1:M=c(.3,.1)*WH,} - Q=${2:c( c(1,.7),c(.5,.7))*WH}, - T=${3:c(.7,.1)*WH} - ), - stroke=${4:'#0000FF'}, - stroke.width=${5:1}, - fill=${6:'none'} -)${0:} -``` -SVGR -``` -library(svgR) -WH<-c(48,32) -# Defined by mouse: edit with care! -ptR<-list( - x=tribble( - ~points, - matrix(NA,2,0) - ) -) -svgR(wh=WH, - path( - d=list( - M=c(.3,.1)*WH, - Q=c( c(1,.7),c(.5,.7))*WH, - T=c(.7,.1)*WH - ), - stroke='#00FFFF', - stroke.width=2, - fill='none' - ) -) -``` -*********************** - -POPUP -``` -Sample Cubic Bezier -``` -SNIPPET -``` -path( - d=list( - ${1:M=c(.2,.9)*WH,} - C=${2:c( c(.3,-1),c(.7,2), c(.8,.2))*WH} - ), - stroke=${3:'#0000FF'}, - stroke.width=${4:1}, - fill=${5:'none'} -)${0:} -``` -SVGR -``` -library(svgR) -WH<-c(48,32) -ptR<-list( - x=matrix(0,2,0) -) -svgR(wh=WH, -#your custom code goes here - path( - d=list( - M=c(.2,.9)*WH, - C=c( c(.3,-1),c(.7,2), c(.8,.2))*WH - ), - stroke='#00FFFF', - stroke.width=2, - fill='none' - ) -) -``` -********************* -*********************** - -POPUP -``` -Sample Extended Cubic Bezier -``` -SNIPPET -``` -path( - d=list( - M=c(.2,.6)*WH, - C=c( c(.4,.0),c(.4,.8), c(.5,.8))*WH, - S=c( c(.6,.0),c(.8,.6))*WH - ), - stroke=${3:'#0000FF'}, - stroke.width=${4:1}, - fill=${5:'none'} -)${0:} -``` -SVGR -``` -library(svgR) -WH<-c(48,32) -ptR<-list( - x=matrix(0,2,0) -) -svgR(wh=WH, -#your custom code goes here - path( - d=list( - M=c(.2,.6)*WH, - C=c( c(.4,.0),c(.4,.8), c(.5,.8))*WH, - S=c( c(.6,.0),c(.8,.6))*WH - ), - stroke='#00FFFF', - stroke.width=2, - fill='none' - ) -) -``` -********************* - - diff --git a/inst/App/sampleProjects/shinyQuibitCtrl/circularArc.R b/inst/App/sampleProjects/shinyQuibitCtrl/circularArc.R deleted file mode 100644 index 87da31a3..00000000 --- a/inst/App/sampleProjects/shinyQuibitCtrl/circularArc.R +++ /dev/null @@ -1,36 +0,0 @@ -library(svgR) -library(tidyverse) -WH<-c(600,400) - -# Defined by mouse: edit with care! -ptR<-list( - x= tribble( - ~points, - matrix(0,2,0) - ) -) - - -pieShape<-function(cxy, R=min(cxy), theta1=0, theta2=2*pi){ - P0=c(cos(theta1),-sin(theta1))*R+cxy - P1=c(cos(theta2),-sin(theta2))*R+cxy - largeArc=ifelse( (theta2-theta1)>pi, 1,0) - sf=0 - d=list( - M=P0, - A=c( c(R,R), 0, largeArc, sf, P1) - ) -} - -R=100 - -svgR(wh=WH, - #your custom code goes here - circle(cxy=WH/2, R=R, fill='lightblue') , - path( - d=pieShape(cxy=WH/2,R=R, 0, 3*pi/4), - stroke='#0000FF', - stroke.width=20, - fill='none' - ) -) diff --git a/inst/App/sampleProjects/shinyQuibitCtrl/pieShape.R b/inst/App/sampleProjects/shinyQuibitCtrl/pieShape.R deleted file mode 100644 index f7b6afb9..00000000 --- a/inst/App/sampleProjects/shinyQuibitCtrl/pieShape.R +++ /dev/null @@ -1,36 +0,0 @@ -library(svgR) -library(tidyverse) -WH<-c(600,600) - -# Defined by mouse: edit with care! -ptR<-list( - x= tribble( - ~points, - matrix( c(c(69,71)), 2), - matrix(0,2,0) - ) -) - - -pieShape<-function(cxy, R=min(cxy), theta1=0, theta2=2*pi){ - P0=c(cos(theta1),-sin(theta1))*R+cxy - P1=c(cos(theta2),-sin(theta2))*R+cxy - largeArc=ifelse( (theta2-theta1)>pi, 1,0) - sf=0 - d=list( - M=cxy, - L=P0, - A=c( c(R,R), 0, largeArc, sf, P1), - Z=0 - ) -} - -svgR(wh=WH, - #your custom code goes here - path( - d=pieShape(cxy=WH/2,R=100, 0, 3*pi/2), - stroke='#0000FF', - stroke.width=2, - fill='lightblue' - ) -) diff --git a/inst/App/sampleProjects/shinyQuibitCtrl/pieShape2.R b/inst/App/sampleProjects/shinyQuibitCtrl/pieShape2.R deleted file mode 100644 index dc2cb521..00000000 --- a/inst/App/sampleProjects/shinyQuibitCtrl/pieShape2.R +++ /dev/null @@ -1,38 +0,0 @@ -library(svgR) -library(tidyverse) -WH<-c(600,400) - -# Defined by mouse: edit with care! -ptR<-list( - x= tribble( - ~points, - matrix(0,2,0) - ) -) - -pieShape2<-function(cxy, R=min(cxy), thetas=c(0,2*pi), dR=30){ - thetas=sort(thetas%%(2*pi)) - RI=R-dR - P=t(matrix(c( cos(thetas), -sin(thetas)),2)) - PP=P*RI + cxy - P= P*R +cxy - largeArc=ifelse(diff(thetas)>pi,1,0) - sf=0 - d=list( - M=P[,1], - A=c( c(R,R), 0, largeArc, sf, P[,2]), - L=PP[,2], - A=c( c(RI,RI), 0, largeArc, 1-sf, PP[,1]), - Z=0 - ) -} - -svgR(wh=WH, - #your custom code goes here - path( - d=pieShape2(cxy=WH/2,R=100, thetas=c(0, 5*pi/4)), - stroke='#0000FF', - stroke.width=2, - fill='lightblue' - ) -) diff --git a/inst/App/sampleProjects/shinyQuibitCtrl/shinyInput.pprj b/inst/App/sampleProjects/shinyQuibitCtrl/shinyInput.pprj deleted file mode 100644 index ccd1344d..00000000 --- a/inst/App/sampleProjects/shinyQuibitCtrl/shinyInput.pprj +++ /dev/null @@ -1,22 +0,0 @@ -{ - "pathToProj": [ - "/home/sup/AA/shinyInput" - ], - "projName": [ - "shinyInput.pprj" - ], - "projType": [ - [ - [ - [ - [ - [ - "generic" - ] - ] - ] - ] - ] - ] -} - diff --git a/inst/App/sampleProjects/shinyQuibitCtrl/shinyInputCntrl.R b/inst/App/sampleProjects/shinyQuibitCtrl/shinyInputCntrl.R deleted file mode 100644 index c502b160..00000000 --- a/inst/App/sampleProjects/shinyQuibitCtrl/shinyInputCntrl.R +++ /dev/null @@ -1,104 +0,0 @@ -library(shiny) -library(svgR) -library(jsonlite) - -try({ removeInputHandler("shinyInputCntrlBinding") }) - -#helper functions - -Normalize<-function(Z){ - S2<-sum(Mod(Z)^2) - if(S2>0){ - Z<-Z/sqrt(S2) - } - Z -} - -# use toJSON for non-trivial initialization -ZtoJSON<-function(Z){ - toJSON(data.frame(re=Re(Z),im=Im(Z))) -} - -# wrapper around svgR code -shinyInputSvgCntrl<-function(params){ - source('shinyInput_svg.R', local=T)$value -} - -# return svg given params -newShinyInputCntrl<-function(ID, WH, CMDS, Z){ - svg<-shinyInputSvgCntrl( - params=list(ID=ID, WH=WH, CMDS=CMDS, Z=Z ) - ) - tmp<-HTML(as.character(svg)) - return(tmp) -} - -# definition of what to call for the given mouse events -id2CMDS<-function(inputId){ - c( - sprintf('shinyInputCntrlBinding.clicked("%s", %d, evt);',inputId, 0 ), - sprintf('shinyInputCntrlBinding.clicked("%s", %d, evt);',inputId, 1 ) - ) -} - -# Cntrl constructor to insert in app ui -shinyInputCntrl<-function(inputId, wh=c(50,100), Z=c(1+0i, 1+1i) ){ - Z<-Normalize(Z) - #CMDS<-paste0("alert('qubit |", c(0,1), "> selected')") - CMDS=id2CMDS(inputId) - - tagList( - singleton(tags$head(tags$script(src = "shinyInput.js"))), - div( id=inputId, - class="shinyInputCntrl", - # customize for initializationby attaching property(s) to this div - 'data-Z'=ZtoJSON(Z), - newShinyInputCntrl(ID=inputId, WH=wh, CMDS=CMDS, Z=Z) - ) - ) -} - -# server to client update -updateShinyInputCntrl<-function(session, inputId, wh=c(200,400), Z=NULL){ - # validate input - if(length(Z)!=2){ - cat('bad dim') - return(NULL) - } - - # normalize first - Z<-Normalize(Z) - # CMDS<-paste0("alert('qubit |", c(0,1), "> selected')") - CMDS=id2CMDS(inputId) - #recreate the entire svg - node<-as.character(newShinyInputCntrl(ID=inputId, WH=wh, CMDS=CMDS, Z=Z)) - mssg<-list(value=node, Z=ZtoJSON(Z)) - session$sendInputMessage(inputId, mssg) -} - - -# preprocess data returned to server from the client -shiny::registerInputHandler( - "shinyInputCntrlBinding", - function(value, shinysession, inputId) { - if(is.null(value) ) { - return("NULL") - } else { - ZDF<-fromJSON(value$Z) - print(ZDF) - if(nrow(ZDF)<2){ - return(NULL) - } - Z=complex(nrow(ZDF), ZDF$re, ZDF$im) - Index=1+value$Index - L<-1-sum(Mod(Z[ Index])^2) - LL<- sum(Mod(Z[-Index])^2) - Z[-Index]<-sqrt(L/LL)*Z[-Index] - print("ZZ") - print(Z) - updateShinyInputCntrl(shinysession, inputId, wh=c(200,400), Z=Z) - return(Z) - } - } -) - diff --git a/inst/App/sampleProjects/shinyQuibitCtrl/shinyInput_svg.R b/inst/App/sampleProjects/shinyQuibitCtrl/shinyInput_svg.R deleted file mode 100644 index b85815db..00000000 --- a/inst/App/sampleProjects/shinyQuibitCtrl/shinyInput_svg.R +++ /dev/null @@ -1,69 +0,0 @@ -library(svgR) -library(tidyverse) - -#-------- params ---------------------- -#` default params -WH<-c(400,800) -CMDS<-paste0("alert('|", c(0,1), "> selected')") -Z<-c( 0+1i, 1-0i) -L<-sqrt(sum(Mod(Z)^2)) -Z<-Z/L -ID<-'myQubitbit' - -#----------function override of params---------- -if(exists("params") ){ - for(n in names(params)){ - assign(n, params[[n]]) - } -} - -#-----any R helper code goes here-------------------------- - - -pieShape<-function(cxy, R=1, thetas=c(0, 2*pi)){ - thetas<-sort(thetas%%(2*pi)) - P<-t(matrix( c(cos(thetas), -sin(thetas)),2)) - P<-P*R+cxy - largeArc=0 - sf=ifelse( diff(thetas)>=pi, 1,0) - d=list( - M=cxy, - L=P[,1], - A=c( c(R,R), 0, largeArc, sf, P[,2]), - Z=0 - ) -} - -stroke.width=10/WH[1] - - -cmplx % - - - - - - diff --git a/inst/App/sampleProjects/shinyQuibitCtrl/www/shinyInput.js b/inst/App/sampleProjects/shinyQuibitCtrl/www/shinyInput.js deleted file mode 100644 index 7d4fa9c2..00000000 --- a/inst/App/sampleProjects/shinyQuibitCtrl/www/shinyInput.js +++ /dev/null @@ -1,78 +0,0 @@ -// JAVASCRIPT - -//INPUT BINDING -var shinyInputCntrlBinding = new Shiny.InputBinding(); -$.extend(shinyInputCntrlBinding, { - find: function(scope) { - console.log('find'); - return $(scope).find(".shinyInputCntrl"); - }, - initialize: function(el){ - // Initialize any data values here - // here we initial Z and the current Index - let iniZ=$(el).attr(`data-Z`); //extract attribute - $(el).data("Z", JSON.parse(iniZ)); //convert to an object and attach - $(el).data('Index',0); // set index - }, - getValue: function(el) { - // used to return the value of this input control - // here we Z and which index was changed - return { - Z: JSON.stringify($(el).data('Z')), - Index: $(el).data('Index') - }; - }, - setValue: function(el, index, value) { - // used for updating input control - let Z=$(el).data("Z"); - $(el).index=index; - Z[index]={ - re:value[0], - im:value[1] - } - $(el).data('Z',Z); - $(el).data('Index',index); - $(el).trigger("change"); - }, - subscribe: function(el, callback) { - // notify server whenever change - $(el).on("change.shinyInputCntrlBinding", function(e) { - callback(); - }); - }, - unsubscribe: function(el) { - $(el).off(".shinyInputCntrlBinding"); - }, - receiveMessage: function(el, data) { //called by server when updating - if(!!data.value){ - var htm=data.value; //htm is string represented a node - var node=jQuery.parseHTML( htm ); - $(el).empty().append(node); - - $(el).data("Z", data.Z); - // alternatively, set value but be careful about index - } - }, - mouse2pt: function(id, x, y){ //method to convert mouse coord to svg coord - var thisSVG=document.querySelector("#" + id ); - thisSVG=document.querySelector("svg#" + id ); - var pt= thisSVG.createSVGPoint(); - pt.x = x; - pt.y = y; - return pt.matrixTransform(thisSVG.getScreenCTM().inverse()); - }, - clicked: function(ctrlId, index, evt){ - let svgId=ctrlId + index; - let pt = this.mouse2pt(svgId, evt.clientX, evt.clientY); - let el = "#" + ctrlId; - let value =[pt.x, - pt.y] ; - this.setValue(el, index, value); - }, - getType: function(el){ - return "shinyInputCntrlBinding"; - } -}); - -// REGISTER INPUT BINDING -Shiny.inputBindings.register(shinyInputCntrlBinding); - diff --git a/inst/App/sampleProjects/zSortingShapes1/.workspace/PTR-TABID308f3cc5ee2a.rda b/inst/App/sampleProjects/zSortingShapes1/.workspace/PTR-TABID308f3cc5ee2a.rda deleted file mode 100644 index 641b6fae..00000000 Binary files a/inst/App/sampleProjects/zSortingShapes1/.workspace/PTR-TABID308f3cc5ee2a.rda and /dev/null differ diff --git a/inst/App/sampleProjects/zSortingShapes1/.workspace/currentTab.rda b/inst/App/sampleProjects/zSortingShapes1/.workspace/currentTab.rda deleted file mode 100644 index 1de2f864..00000000 Binary files a/inst/App/sampleProjects/zSortingShapes1/.workspace/currentTab.rda and /dev/null differ diff --git a/inst/App/sampleProjects/zSortingShapes1/zSortShapes1.R b/inst/App/sampleProjects/zSortingShapes1/zSortShapes1.R deleted file mode 100644 index 12e8944d..00000000 --- a/inst/App/sampleProjects/zSortingShapes1/zSortShapes1.R +++ /dev/null @@ -1,35 +0,0 @@ -library(svgR) -library(tidyverse) -WH<-c(600,400) - -# We place all items in the same tibble, using a helper function -# to determine which shape to render. -# Thus z-sorting can again be accomplished by simply -# drag and drop the rows - - -ptR<-list( - x= tribble( - ~shape, ~fill, ~points, - 'ellipse', 'red', matrix( c(c(173,122),c(275,172)), 2), - 'rect', '#001EFF', matrix( c(c(113,63),c(278,141)), 2), - 'ellipse', '#FFEE00', matrix( c(c(208,86),c(298,148)), 2), - 'rect', '#00FF33', matrix( c(c(222,145),c(342,222)), 2) - ) -) - - -ffn %