Only Table in rpivotTable - r

I'm using the rpivotTable package in Shiny application and I'd like to have only the choice of 'Table' for the users (no charts)
The RenderName argument is only used to choose the default display...
output$pivot <- renderRpivotTable(
rpivotTable(iris,
rendererName = "Table" )
)
Many thanks in advance !

There are multiple issues here.
you can specify renderers via the anonymos renderers argument in rpivotTable(). I have the JS code form here.
however, there is a bug when only selecting one option. In this case, rpivotTable() wraps the argument in a list again (see the Map() call in the original function code) and the forwarding to JS fails.
Therefore, I accounted for this issue and extended the function a bit. Play around with aggregators/renderers to see how it behaves differently to the original rpivotTable() function.
# define own function
my_rpivotTable <- function (data, rows = NULL, cols = NULL, aggregatorName = NULL,
vals = NULL, rendererName = NULL, sorter = NULL, exclusions = NULL,
inclusions = NULL, locale = "en", subtotals = FALSE, ...,
width = 800, height = 600, elementId = NULL)
{
if (length(intersect(class(data), c("data.frame", "data.table",
"table", "structable", "ftable"))) == 0) {
stop("data should be a data.frame, data.table, or table",
call. = F)
}
if (length(intersect(c("table", "structable", "ftable"),
class(data))) > 0)
data <- as.data.frame(data)
params <- list(rows = rows, cols = cols, aggregatorName = aggregatorName,
vals = vals, rendererName = rendererName, sorter = sorter,
...)
params <- Map(function(p) {
# added to the class check -------------------------------------------------
if (length(p) == 1 && class(p[[1]]) != "JS_EVAL") {
p = list(p)
}
return(p)
}, params)
par <- list(exclusions = exclusions, inclusions = inclusions)
params <- c(params, par)
params <- Filter(Negate(is.null), params)
x <- list(data = data, params = params, locale = locale,
subtotals = subtotals)
htmlwidgets::createWidget(name = "rpivotTable", x, width = width,
height = height, elementId = elementId, package = "rpivotTable")
}
# create the pivot table
my_rpivotTable(
expand.grid(LETTERS, 1:3),
aggregatorName = "Count",
aggregators = list(Sum = htmlwidgets::JS('$.pivotUtilities.aggregators["Sum"]'),
Count = htmlwidgets::JS('$.pivotUtilities.aggregators["Count"]')),
rendererName = "fancyTable",
renderers = list(fancyTable = htmlwidgets::JS('$.pivotUtilities.renderers["Table"]'))
)

Related

Remove columns with many NA values using mlr3pipelines

I am trying to remove columns where proportion of NA value are greater than na_cutoff threshold using mlr3pipelines.
Here is my try:
library(mlr3)
library(mlr3pipelines)
task = tsk("iris")
dt = task$data()
dt[1:50, Sepal.Width := NA]
task_ = as_task_classif(dt, target = "Species")
graph = po("removeconstants", id = "removeconstants", ratio = 0.01) %>>%
po("select", id = "drop_na_cols")
ps = ParamSet$new(list(ParamDbl$new("na_cutoff", lower = 0, upper = 1, default = 0.2)))
graph$param_set$add(ps)
graph$param_set
graph$param_set$trafo = function(x, param_set) {
na_cutoff = x$na_cutoff
print(na_cutoff)
x$drop_na_cols.selector = function(task) {
fn = task$feature_names
data = task$data(cols = fn)
drop <- which(colMeans(is.na(data)) > na_cutoff)
fn[-drop]
}
x$na_cutoff = NULL
x
}
train_res = graph$train(task_)
train_res$drop_na_cols.output$data()
The problem is that last column is not removed even it should be.
In general, trafos are not meant for parameter sets.
I.e. internally, when the Graph accesses the parameters, the parameter transformation is not applied.
They are intended to create search spaces for black-box optimization, including hyperparameter optimization of ML models.
Also, you modifying the parameter set of an existing Graph is a bad idea.
The way to go I believe is to use the PipeOpSelect with a custom selector: https://mlr3pipelines.mlr-org.com/reference/Selector.html
Following this issue https://github.com/mlr-org/mlr3pipelines/issues/313
I thought the recommended way to do this is through trafo on select pipe.
Nevertheless, I have just created new pipeop that removes columns with many NA values:
library(mlr3pipelines)
library(mlr3verse)
library(mlr3misc)
library(R6)
PipeOpDropNACol = R6::R6Class(
"PipeOpDropNACol",
inherit = mlr3pipelines::PipeOpTaskPreprocSimple,
public = list(
initialize = function(id = "drop.nacol", param_vals = list()) {
ps = ParamSet$new(list(
ParamDbl$new("cutoff", lower = 0, upper = 1, default = 0.05, tags = c("dropnacol_tag"))
))
ps$values = list(cutoff = 0.2)
super$initialize(id, param_set = ps, param_vals = param_vals)
}
),
private = list(
.get_state = function(task) {
pv = self$param_set$get_values(tags = "dropnacol_tag")
print(pv$cutoff)
features_names = task$feature_names
data = task$data(cols = features_names)
print(data)
many_na = sapply(data, function(column) (sum(is.na(column))) / length(column) > pv$cutoff)
print(many_na)
list(cnames = colnames(data)[-many_na])
},
.transform = function(task) {
task$select(self$state$cnames)
}
)
)
# no group variable
task = tsk("iris")
dt = task$data()
dt[1:50, Sepal.Width := NA]
task = as_task_classif(dt, target = "Species")
gr = Graph$new()
gr$add_pipeop(PipeOpDropNACol$new())
result = gr$train(task)
result[[1]]$data()
gr$predict(task)

Altering code behind crosstalk's filter_slider() function

I am trying to modify the appearance of a crosstalk filter slider by changing its colour and font. There is no built-in option to do this within the filter_slider() function, so I looked up the code behind the function to see if it specifies the colour and font of the output. I found nothing that indicates that it does, so I was wondering if it is possible to add some lines to the function that enable changing the colour of the slider and its font. I have very limited knowledge of writing functions, so I do not know how to modify a complicated function like this one. I am attaching the code behind the filter_slider() function below.
function (id, label, sharedData, column, step = NULL, round = FALSE,
ticks = TRUE, animate = FALSE, width = NULL, sep = ",",
pre = NULL, post = NULL, timeFormat = NULL, timezone = NULL,
dragRange = TRUE, min = NULL, max = NULL)
{
if (is.character(column)) {
column <- lazyeval::f_new(as.symbol(column))
}
df <- sharedData$data(withKey = TRUE)
col <- lazyeval::f_eval(column, df)
values <- na.omit(col)
if (is.null(min))
min <- min(values)
if (is.null(max))
max <- max(values)
value <- range(values)
ord <- order(col)
options <- list(values = col[ord], keys = df$key_[ord], group = sharedData$groupName())
findStepSize <- function(min, max, step) {
if (!is.null(step))
return(step)
range <- max - min
if (range < 2 || hasDecimals(min) || hasDecimals(max)) {
step <- pretty(c(min, max), n = 100)
step[2] - step[1]
}
else {
1
}
}
if (inherits(min, "Date")) {
if (!inherits(max, "Date") || !inherits(value,
"Date"))
stop("`min`, `max`, and `value must all be Date or non-Date objects")
dataType <- "date"
if (is.null(timeFormat))
timeFormat <- "%F"
}
else if (inherits(min, "POSIXt")) {
if (!inherits(max, "POSIXt") || !inherits(value,
"POSIXt"))
stop("`min`, `max`, and `value must all be POSIXt or non-POSIXt objects")
dataType <- "datetime"
if (is.null(timeFormat))
timeFormat <- "%F %T"
}
else {
dataType <- "number"
}
if (isTRUE(round))
round <- 0
else if (!is.numeric(round))
round <- NULL
step <- findStepSize(min, max, step)
step <- signif(step, 14)
if (dataType %in% c("date", "datetime")) {
to_ms <- function(x) 1000 * as.numeric(as.POSIXct(x))
step <- to_ms(max) - to_ms(max - step)
min <- to_ms(min)
max <- to_ms(max)
value <- to_ms(value)
}
range <- max - min
if (ticks) {
n_steps <- range/step
scale_factor <- ceiling(n_steps/10)
n_ticks <- n_steps/scale_factor
}
else {
n_ticks <- NULL
}
sliderProps <- dropNulls(list(`data-type` = if (length(value) >
1) "double", `data-min` = formatNoSci(min),
`data-max` = formatNoSci(max), `data-from` = formatNoSci(value[1]),
`data-to` = if (length(value) > 1) formatNoSci(value[2]),
`data-step` = formatNoSci(step), `data-grid` = ticks,
`data-grid-num` = n_ticks, `data-grid-snap` = FALSE,
`data-prettify-separator` = sep, `data-prefix` = pre,
`data-postfix` = post, `data-keyboard` = TRUE,
`data-keyboard-step` = step/(max - min) * 100,
`data-drag-interval` = dragRange, `data-round` = round,
`data-data-type` = dataType, `data-time-format` = timeFormat,
`data-timezone` = timezone))
sliderProps <- lapply(sliderProps, function(x) {
if (identical(x, TRUE))
"true"
else if (identical(x, FALSE))
"false"
else x
})
sliderTag <- div(class = "form-group crosstalk-input",
class = "crosstalk-input-slider js-range-slider",
id = id, style = if (!is.null(width))
paste0("width: ", validateCssUnit(width), ";"),
if (!is.null(label))
controlLabel(id, label), do.call(tags$input, sliderProps),
tags$script(type = "application/json", `data-for` = id,
jsonlite::toJSON(options, dataframe = "columns",
pretty = TRUE)))
if (identical(animate, TRUE))
animate <- shiny::animationOptions()
if (!is.null(animate) && !identical(animate, FALSE)) {
if (is.null(animate$playButton))
animate$playButton <- shiny::icon("play", lib = "glyphicon")
if (is.null(animate$pauseButton))
animate$pauseButton <- shiny::icon("pause",
lib = "glyphicon")
sliderTag <- tagAppendChild(sliderTag, tags$div(class = "slider-animate-container",
tags$a(href = "#", class = "slider-animate-button",
`data-target-id` = id, `data-interval` = animate$interval,
`data-loop` = animate$loop, span(class = "play",
animate$playButton), span(class = "pause",
animate$pauseButton))))
}
htmltools::browsable(attachDependencies(sliderTag, c(ionrangesliderLibs(),
crosstalkLibs())))
}
To change the font and colour of the slider, you don't need to modify the function. Instead, you can add some additional CSS to customise the appearance.
If you run the following Rmarkdown file, you can see the slider now has blue text and is in cursive font, with a red bar.
---
title: "Crosstalk Slider CSS"
output: html_document
---
<style>
.crosstalk-input-slider, .irs-grid-text{
color: blue;
font-family: cursive;
}
.irs-bar {
background-color:red;
}
</style>
## Crosstalk Slider CSS
```{r}
library(crosstalk)
shared_mtcars <- SharedData$new(mtcars)
filter_checkbox("cyl", "Cylinders", shared_mtcars, ~cyl, inline = TRUE)
filter_slider("hp", "Horsepower", shared_mtcars, ~hp, width = "100%")
filter_select("auto", "Automatic", shared_mtcars, ~ifelse(am == 0, "Yes", "No"))
```

How to modify pre-existing function in local environment in R

I am trying to modify an existing function by copy and pasting it to an R script, and assigning it to a new function object in my local environment. However the new function cannot find functions that are called to within the original function. How can I fix this without looking up and finding each function individually? I am guessing that the original function is somehow linked to the package or its dependencies and 'knows where to look' for the missing function, but I cannot figure out how to do this with my new copy-and-pasted function.
library("camtrapR")
Print the function name
activityDensity
The output here is the code for this function. I have omitted it here because it is long (and I have pasted it below), but I copy and paste the output of the function code exactly (see below where I assign this exact code to a new function), except for the last two lines of output, which I think are important:
<bytecode: 0x000000002a2d1e20>
<environment: namespace:camtrapR>
So now I assign the copy and pasted code from the output above to a new function with New <-
New <- function (recordTable, species, allSpecies = FALSE, speciesCol = "Species",
recordDateTimeCol = "DateTimeOriginal", recordDateTimeFormat = "%Y-%m-%d %H:%M:%S",
plotR = TRUE, writePNG = FALSE, plotDirectory, createDir = FALSE,
pngMaxPix = 1000, add.rug = TRUE, ...)
{
wd0 <- getwd()
mar0 <- par()$mar
on.exit(setwd(wd0))
on.exit(par(mar = mar0), add = TRUE)
recordTable <- dataFrameTibbleCheck(df = recordTable)
timeZone <- "UTC"
checkForSpacesInColumnNames(speciesCol = speciesCol, recordDateTimeCol = recordDateTimeCol)
if (!is.data.frame(recordTable))
stop("recordTable must be a data frame", call. = FALSE)
if (!speciesCol %in% colnames(recordTable))
stop(paste("speciesCol = \"", speciesCol, "\" is not a column name in recordTable",
sep = ""), call. = FALSE)
if (!recordDateTimeCol %in% colnames(recordTable))
stop(paste("recordDateTimeCol = \"", recordDateTimeCol,
"\" is not a column name in recordTable", sep = ""),
call. = FALSE)
stopifnot(is.logical(c(allSpecies, writePNG, plotR, createDir)))
if (allSpecies == FALSE) {
stopifnot(species %in% recordTable[, speciesCol])
stopifnot(hasArg(species))
}
recordTable$DateTime2 <- parseDateTimeObject(inputColumn = recordTable[,
recordDateTimeCol], dateTimeFormat = recordDateTimeFormat,
timeZone = timeZone)
recordTable$Time2 <- format(recordTable$DateTime2, format = "%H:%M:%S",
usetz = FALSE)
recordTable$Time.rad <- (as.numeric(as.POSIXct(strptime(recordTable$Time2,
format = "%H:%M:%S", tz = timeZone))) - as.numeric(as.POSIXct(strptime("0",
format = "%S", tz = timeZone))))/3600 * (pi/12)
if (isTRUE(writePNG)) {
if (hasArg(plotDirectory)) {
if (isTRUE(createDir)) {
dir.create(plotDirectory, recursive = TRUE, showWarnings = FALSE)
setwd(plotDirectory)
}
else {
stopifnot(file.exists(plotDirectory))
setwd(plotDirectory)
}
}
else {
stop("writePNG is TRUE. Please set plotDirectory",
call. = FALSE)
}
}
pngWidth <- pngMaxPix
pngHeight <- round(pngMaxPix * 0.8)
if (allSpecies == FALSE) {
subset_species <- subset(recordTable, recordTable[, speciesCol] ==
species)
if (nrow(subset_species) == 1)
stop(paste(species, "had only 1 record. Cannot estimate density."),
call. = FALSE)
try_error_tmp <- try({
if (isTRUE(writePNG))
png(filename = paste("activity_density_",
species, "_", Sys.Date(), ".png",
sep = ""), width = pngWidth, height = pngHeight,
units = "px", res = 96, type = "cairo")
if (isTRUE(writePNG) | isTRUE(plotR)) {
densityPlot(subset_species$Time.rad, main = paste("Activity of",
species), rug = add.rug, ...)
mtext(paste("number of records:", nrow(subset_species)),
side = 3, line = 0)
}
if (isTRUE(writePNG))
dev.off()
}, silent = TRUE)
if (class(try_error_tmp) == "try-error")
warning(paste(toupper(species), ": ", try_error_tmp[1],
" - SKIPPED", sep = ""), call. = FALSE)
}
else {
subset_species_list <- list()
for (i in 1:length(unique(recordTable[, speciesCol]))) {
spec.tmp <- unique(recordTable[, speciesCol])[i]
subset_species <- subset(recordTable, recordTable[,
speciesCol] == spec.tmp)
plot_main_title <- paste("Activity of", spec.tmp)
if (nrow(subset_species) == 1) {
warning(paste(toupper(spec.tmp), ": It had only 1 record. Cannot estimate density. - SKIPPED",
sep = ""), call. = FALSE)
next
}
else {
try_error_tmp <- try({
if (isTRUE(writePNG))
png(filename = paste("activity_density_",
spec.tmp, "_", Sys.Date(), ".png",
sep = ""), width = pngWidth, height = pngHeight,
units = "px", res = 96, type = "cairo")
if (isTRUE(writePNG) | isTRUE(plotR)) {
densityPlot(subset_species$Time.rad, main = plot_main_title,
rug = add.rug, ...)
mtext(paste("number of records:", nrow(subset_species)),
side = 3, line = 0)
}
if (isTRUE(writePNG))
dev.off()
}, silent = TRUE)
if (class(try_error_tmp) == "try-error")
warning(paste(toupper(spec.tmp), ": ",
try_error_tmp[1], " - SKIPPED",
sep = ""), call. = FALSE)
}
subset_species_list[[i]] <- subset_species$Time.rad
names(subset_species_list)[i] <- spec.tmp
}
}
if (allSpecies == FALSE) {
return(invisible(subset_species$Time.rad))
}
else {
return(invisible(subset_species_list))
}
}
Yet, when I try to run this new function (arguments omitted here for clarity), it can't find a function embedded within.
How can I somehow assign this function to look within the original package camtrapR for any dependencies, etc.? and why does the code output from the function not already do this?
New()
Error in dataFrameTibbleCheck(df = recordTable) :
could not find function "dataFrameTibbleCheck"
This answer here: https://stackoverflow.com/a/49277036/9096420 allows one to manually edit and save a function's code for each R session, but it is non-reproducible (not code) that can be shared or re-used.
If New is the new function copied from camtrapR then use
environment(New) <- asNamespace("camtrapR")
to ensure that the function calls in its body are looked up in the correct places.

Create argument list using lapply for do.call

I'm trying to pass a set of modified arguments from a larger function to arguments in a nested function. This is an argument supplied from the larger function:
time_dep_covariates_list = c(therapy_start = "Start of Therapy",
therapy_end = "End of Therapy")
I have these sets of constant arguments:
tmerge_args_1 <- alist(data1 = analytic_dataset,
data2 = analytic_dataset,
id = patientid,
tstop = adv_dx_to_event,
death_censor = event(adv_dx_to_event))
And I want to append these modified arguments to that argument list:
tmerge_args_2 <- lapply(1:length(time_dep_covariates_list), function(x){
tmerge_args <<- c(tmerge_args, alist('var' = tdc(var)) )
paste0(names(time_dep_covariates_list[x])," =
tdc(",names(time_dep_covariates_list[x]), ")")
})
> tdc_args
[[1]]
[1] "therapy_start = tdc(therapy_start)"
[[2]]
[1] "therapy_end = tdc(therapy_end)"
I want to create a do.call that handles the arguments like so:
count_process_form <- do.call(tmerge, args = c(tmerge_args_1,
tmerge_args_2)
That would be identical to the following:
tmerge(data1 = analytic_dataset, data2 = analytic_dataset,
id = patientid, tstop = adv_dx_to_event,
therapy_start = tdc(therapy_start), therapy_end = tdc(therapy_end)
It works fine with tmerge_args_1 by itself, but as the args_2 are character and not language elements, I get this error:
Error in (function (data1, data2, id, ..., tstart, tstop, options) :
all additional argments [sic] must have a name:
How can I modify the list I'm creating for args_2 so they're stored as arguments that do.call can understand? Or am I approaching this all wrong?
Thanks!
Here is a reproducible example:
analytic_dataset= data_frame(patientid = sample(1:1000,5),
adv_dx_to_event = sample(100:200, 5),
death_censor = sample(0:1,5, replace = T),
therapy_start = sample(1:20,5),
therapy_stop = sample(40:100,5))
The below would be passed in from a function:
time_dep_covariates_list = c(therapy_start = "Start of Therapy",
therapy_end = "End of Therapy")
tmerge_args_1 <- alist(data1 = analytic_dataset,
data2 = analytic_dataset,
id = patientid,
tstop = adv_dx_to_event,
death_censor = event(adv_dx_to_event))
do.call(tmerge,tmerge_args_1) #this works
tmerge_args_2 <- lapply(1:length(time_dep_covariates_list), function(x){
tmerge_args <<- c(tmerge_args, alist('var' = tdc(var)) )
paste0(names(time_dep_covariates_list[x])," = tdc(",names(time_dep_covariates_list[x]), ")")
})
do.call(tmerge,tmerge_args_1,tmerge_args_2) # this doesn't```

How to preselect a variable value of column or row variables in HTML widget rpivotTable?

I am using the very interesting html widget rpivotTable. I know how to preselect variables that are added as rows or columns to the pivottable, but what I really need is a preselection of certain values of these variables.
As an example of what I mean I use the code from the vignette page:
library(rpivotTable)
data(HairEyeColor)
rpivotTable(
data = HairEyeColor, rows = "Hair",cols = "Eye", vals = "Freq",
aggregatorName = "Sum", rendererName = "Table",
sorters = "function(attr) {
var sortAs = $.pivotUtilities.sortAs;
if (attr == \"Hair\"){
return sortAs([\"Red\", \"Brown\", \"Blond\", \"Black\"]);}
}", width = "100%", height = "400px"
)
If I want, e.g. to preselect the value "Red" of the "Hair" variable, is it possible to do that in this script? Something like:
library(rpivotTable)
data(HairEyeColor)
rpivotTable(
data = HairEyeColor, rows = "Hair",cols = "Eye", vals = "Freq",
aggregatorName = "Sum", rendererName = "Table", sorters = "
function(attr) {
var sortAs = $.pivotUtilities.sortAs;
if (attr == \"Hair\") { return select([\"Red\"]); }
}", width = "100%", height = "400px"
)
I know this doesn't work but is it the way to go?
Yes, if I understand correctly, this can be accomplished with inclusions and exclusions. The format is a little funky though and requires everything to be a list.
library(rpivotTable)
data(HairEyeColor)
rpivotTable(
data = HairEyeColor,
rows = "Hair",
cols="Eye",
vals = "Freq",
aggregatorName = "Sum",
rendererName = "Table",
inclusions = list(
"Hair" = list("Red")
)
)

Resources