Remove '¶' character from R saveWidget output - html

I'm generating a reactable object and saving it in a HTML widget with saveWidget function, my code is like this: (qmd document)
```{css, echo = FALSE}
.tag {
display: inline-block;
padding: 2px 12px;
border-radius: 15px;
font-weight: 600;
font-size: 12px;
overflow-y: scroll;
height:400px;
}
```
Generate and save table:
```{r}
library("reactable")
library("htmlwidgets")
reactable(data = data_table,
class = "tag",
filterable = TRUE,
rownames = FALSE,
selection = "multiple",
showPageSizeOptions = TRUE,
paginationType = "jump",
showSortable = TRUE,
highlight = TRUE,
resizable = TRUE,
rowStyle = list(cursor = "pointer"),
onClick = "select") %>%
saveWidget(.,
"table_name.html",
selfcontained = T,
libdir = "lib"
)
```
My problem is: when I open the output ("table_name.html") there's a string with "¶¶¶¶¶¶", I don't know how to remove it.
This is how it looks:

Judging from the link in the comments, this is fixed in the widget. However, if one should run into this in a different context, then on could also use a Lua filter.
local sep = pandoc.Inlines{pandoc.Space(), pandoc.Str '¶', pandoc.Space()}
function Inlines (inlines)
for i = #inlines - 2, 1, -1 do
if pandoc.Inlines{inlines[i], inlines[i+1], inlines[i+2]} == sep then
inlines:remove(i+2); inlines:remove(i+1); inlines:remove(i)
end
end
return inlines
end
Save the above to a file, say remove-pilcrow.lua, and use it with
---
output:
html_document:
pandoc_args: ['--lua-filter=remove-pilcrow.lua']
---
in R Markdown or
---
filters:
- remove-pilcrow.lua
---
in Quarto.

Related

Running timeseries graphing function in Rmd producing cluttered x-axis labels (not present in test code)

I have a folder of xx .csv timeseries that I want to graph and knit into a clean HTML document. I have a ggplot code that produces the plot that I want using a single timeseries.csv. However, when I try to put the bones of that ggplot code in a function inside of a for loop to run each of the timeseries.csv files through the function I get a some plots with pretty different formatting.
Plot generated with my test ggplot code:
Plot generated with function and for loop:
Changes I'm trying to make to the ugly Rmd plot:
Nicely space the x-axis tick marks to whole mins (i.e. "11:14:00", "11:15:00")
Connect the data points (solved with subbing geom_line() with geom_path())
Example Rmd Code Below. Please Note that the graphs produced still have nice formatting, I'm not sure how to reproduce this problem sort of posting a 500 row dataframe. I also don't know how to post my rmd code without SO using the formatting commands in this post, so I threw in at 3 of " around my header formatting and at the end of the code to disable it.
Edits and Updates
I am getting a persistent error geom_path: Each group consists of only one observation. Do you need to adjust the group
aesthetic?.
As suggested by the commenters I tried removing plot() and using the the createChlDiffPlot() directly and replacing plot() with print(). Both produce the same ugly plots as before.
Replaced geom_line() with geom_path(). The points are now connected! x-axis cluttering is still there.
Time variable is reading as hms num
Many thanks for any help on this!
```
---
title: "Chl Filtration"
output:
flexdashboard::flex_dashboard:
theme: yeti
orientation: rows
editor_options:
chunk_output_type: console
---
```{r setup}
library(flexdashboard)
library(dplyr)
library(ggplot2)
library(hms)
library(ggthemes)
library(readr)
library(data.table)
#### Example Data
df1 <- data.frame(Time = as_hms(c("11:22:33","11:22:34","11:22:35","11:22:38","11:23:00","11:23:01","11:23:02")),
Chl_ug_L_Up = c(0.2,0.1,0.25,-0.2,-0.3,-0.15,0.1),
Chl_ug_L_Down = c(0.5,0.4,0.3,0.2,0.1,0,-0.1))
df2 <- data.frame(Time = as_hms(c("08:02:33","08:02:34","08:02:35","08:02:40","08:02:42","08:02:43","08:02:49")),
Chl_ug_L_Up = c(-0.2,-0.1,-0.25,0.2,0.3,0.15,-0.1),
Chl_ug_L_Down = c(-0.1,0,0.1,0.2,0.3,0.4,0.1))
data_directory = "./" # data folder in R project folder in the real deal
output_directory = "./" # output graph directory in R project folder
write_csv(df1, file.path(data_directory, "SO_example_df1.csv"))
write_csv(df2, file.path(data_directory, "SO_example_df2.csv"))
#### Function to create graphs
createChlDiffPlot = function(aTimeSeriesFile, aFileName, aGraphOutputDirectory, aType)
{
aFile_Mod = aTimeSeriesFile %<>%
select(Time, Chl_ug_L_Up, Chl_ug_L_Down) %>%
mutate(Chl_diff = Chl_ug_L_Up - Chl_ug_L_Down)
one_plot = ggplot(data = aFile_Mod, aes(x = Time, y = Chl_diff)) + # tried adding 'group = 1' in aes to connect points
geom_path(size = 1, color = "green") +
geom_point(color = "green") +
theme_gdocs() +
theme(axis.text.x = element_text(angle = 45, hjust = 1),
legend.title = element_blank()) +
labs(x = "", y = "Chl Difference", title = paste0(aFileName, " - ", "Filtration"))
one_graph_name = paste0(gsub(".csv", "", aFileName), "_", aType, ".pdf")
ggsave(one_graph_name, one_plot, dpi = 600, width = 7, height = 5, units = "in", device = "pdf", aGraphOutputDirectory)
return(one_plot)
}
"``` ### remove the quotes when running example
Plots - After Velocity Adjustment
=====================================" ### remove quotes when running example
```{r, fig.width=13.5, fig.height=5}
all_files_Filtration = list.files(data_directory, pattern = ".csv")
# Loop to plot function
for(file in 1 : length(all_files_Filtration))
{
file_name = all_files_Filtration[file]
one_file = fread(file.path(data_directory, file_name))
# plot the time series agains
plot(createChlDiffPlot(one_file, file_name, output_directory, "Velocity_Paired"))
}
"``` #remove quotes when running example
```
I finally figured it out.
1) Replacing geom_line() with geom_path() connected the data points when rendered in Rmd.
2) df1$Time was formatted as a difftime object. When I looked at the dataframe in the global environment, Time :hmsnum 11:11:09 .... This made me think my format was ok, but when I ran class(df1$Time) I got [1] "hms" "difftime". With a quick google I found out difftime objects are not quite the same as hms, and my original time was generated by subtracting times. I added a conversion into my mutate function:
select(Time, Chl_ug_L_Up, Chl_ug_L_Down) %>%
mutate(Chl_diff = Chl_ug_L_Up - Chl_ug_L_Down,
Time = as_hms(Time)) # convert difftime objecct to hms
ggplot I think has some auto-formatting for hms variables, which is why difftime variable was producing ugly crowded x- axes.

R Shiny Image without padding/ stretched across page using css

I'm building a shiny dashboard and I want an image to stretch across the top of the dashboard body with no padding. I'm new to customizing apps and CSS, and I'd prefer to keep my css inline if possible.
This is what I have right now:
I'd like to extend the image as indicated by blue arrows/ red outline below.
Here's code for what I have so far:
library('shiny')
library('shinyjs')
library('shinydashboard')
##########
header<-dashboardHeader(titleWidth = 325)
header$children[[2]]$children <-
#tags$a(tags$img(src='image.PNG',height='45',width='184'))
######
body<-dashboardBody( tags$style(".content {background-color: black;}"),
useShinyjs(),
tags$style(type='text/css', ".skin-blue .main-header .logo {background-color: #000000}" ),
tags$style(type='text/css', ".skin-blue .main-header .logo:hover {background-color: #000000}"),
tags$style(type='text/css', ".skin-blue .main-header .navbar {background-color: #000000}"),
tags$style(type="text/css",".shiny-output-error { visibility: hidden; }",".shiny-output-error:before { visibility: hidden; }"),
fluidPage(
img(src="img2.PNG",height="100%", width="100%"),
tabBox("Menu Surf Database", width = 12,
tabPanel("Menu Surf Database",
tabsetPanel(
tabPanel("LTO Survey results",
h2(strong(textOutput("t"))),
h4(textOutput("Description")),
h2(strong("LTO Results"),align='center'),
h4(strong(textOutput("Price"))),
br(),
plotOutput("Q4plot",height = 200),
br(),br(),
plotOutput("seasonPlot",height=200),
br(),br(),
plotOutput("Q1plot"),
br(),br()),
tabPanel("Demographics",
h2(strong(textOutput("t2"))),
h4(textOutput("Description2")),
h2(strong("Demographics of Top Two Box:"),align='center'),
h3(strong("By Purchase Intent"),align= "center"),
br(),
plotOutput("demoPlot1"),
plotOutput("demoPlot2")
))),
tabPanel("Exploratory Comparison",
tabsetPanel(
tabPanel("Visuals",
h2(strong("Proprietary Menu Surf Results:")),
selectInput("index",label = "Index by:",choices = c("Meal Part","Day Part"),selected = "Meal Part",multiple = FALSE),
checkboxInput("addItem", label="Include sidebar item for comparision?", value = FALSE, width = NULL),
h4(strong("Purchase Intent Indices:")),
plotOutput("prop1"),
h4(strong("Uniqueness Indices:")),
plotOutput("prop2"),
h4(strong("Draw Indices:")),
plotOutput("prop3"),
h4(strong("Cravebility Indices:")),
plotOutput("prop4"),
h4(strong("Brand Fit Indices")),
plotOutput("prop5")
),
tabPanel("Tables",
h2(strong("Menu Surf Results, tables:")),
h3("Purchase Intent"),
br(),
dataTableOutput("propTable1")
)))
)))
sidebar<-dashboardSidebar(width = 325,
conditionalPanel(
condition = "$('li.active a').first().html()==='Menu Surf Database'",
h4("Filters:"),
br(),
selectInput('month',label='Month:',choices= month.name,multiple = TRUE,selected = "March"),
selectInput("year",label= "Year:",choices= c("2017"),multiple = FALSE,selected = "2017"),
selectInput("daypart",label = "Day Part:",choices=c("Breakfast","Lunch/Dinner"),selected = c("Breakfast","Lunch/Dinner"),multiple = TRUE),
selectInput("mealpart",label="Meal Part:",choices =c("Adult Beverage","App/Starter","Dessert","Ent/Main Dish","Non-Alcohol Beverage","Side/Extra","Snack"),selected = c("Adult Beverage","App/Starter","Dessert","Ent/Main Dish","Non-Alcohol Beverage","Side/Extra","Snack"),multiple = TRUE),
selectInput("courseCategory",label = "Course Category:",choices = c('All','Asian Bowl','Baked Goods','Beef Dish','Beverage','Breaded Other',
'Breaded Protein','Breaded Vegetables','Breads','Breakfast Starch',
'Burgers','Chicken Dish','Combo Plates','Egg Dish','Fish Dish','Fried Dessert',
'Fries','Frozen Beverage','Ice Cream','Mexican','Mixed Grill','Nachos','Pasta/Noodles',
'Pizza','Pork Dish','Salad Main Dish','Sandwich','Shellfish Dish','Soup','Specialty Drinks'
),selected= 'All',multiple = FALSE),
#textOutput('test'),
uiOutput('restChoices'),
uiOutput('itemChoices'),
br(),
h5("Edit data by demographic features below:"),
selectInput('gender',label = "Gender:",choices = c("Female","Male"),multiple = TRUE,selected = c("Female","Male")),
selectInput('generation',label = "Generation:",choices = c("Generation Z","Millennials","Generation X","Baby Boomers","Matures"),selected = c("Generation Z","Millennials","Generation X","Baby Boomers","Matures"),multiple = TRUE),
selectInput('ethnicity',label ='Ethnicity:',choices = c("Asian","Black/African American (non-Hispanic)","Caucasian (non-Hispanic)","Hispanic","Mixed ethnic background","Other"),selected = c("Asian","Black/African American (non-Hispanic)","Caucasian (non-Hispanic)","Hispanic","Mixed ethnic background","Other"),multiple = TRUE),
selectInput('ea',label = 'Eater Archetype:', choices = c("Affluent Socializers","Bargain Hunters","Busy Balancers","FS Hobbyist","FS Hobbyists","Functional Eater","Functional Eaters","Habitual Matures","Health Enthusiast","Health Enthusiasts"),selected = c("Affluent Socializers","Bargain Hunters","Busy Balancers","FS Hobbyist","FS Hobbyists","Functional Eater","Functional Eaters","Habitual Matures","Health Enthusiast","Health Enthusiasts"),multiple = TRUE)
),
conditionalPanel(
condition = "$('li.active a').first().html()==='Exploratory Comparison'",
#h5("The Exploratory Comparison tab allows you to view results for many items. Please filter for your results below."),
h4("Filters:"),
br(),
selectInput('month2',label='Month:',choices= month.name,multiple = TRUE,selected = "March"),
selectInput("year2",label= "Year:",choices= c("2017"),multiple = FALSE,selected = "2017"),
selectInput("daypart2",label = "Day Part:",choices=c("Breakfast","Lunch/Dinner"),selected = c("Breakfast","Lunch/Dinner"),multiple = TRUE),
selectInput("mealpart2",label="Meal Part:",choices =c("Adult Beverage","App/Starter","Dessert","Ent/Main Dish","Non-Alcohol Beverage","Side/Extra","Snack"),selected = c("Adult Beverage","App/Starter","Dessert","Ent/Main Dish","Non-Alcohol Beverage","Side/Extra","Snack"),multiple = TRUE),
selectInput("courseCategory2",label = "Course Category:",choices = c('All','Asian Bowl','Baked Goods','Beef Dish','Beverage','Breaded Other',
'Breaded Protein','Breaded Vegetables','Breads','Breakfast Starch',
'Burgers','Chicken Dish','Combo Plates','Egg Dish','Fish Dish','Fried Dessert',
'Fries','Frozen Beverage','Ice Cream','Mexican','Mixed Grill','Nachos','Pasta/Noodles',
'Pizza','Pork Dish','Salad Main Dish','Sandwich','Shellfish Dish','Soup','Specialty Drinks'
),selected= 'All',multiple = FALSE),
uiOutput('restChoices2'),
br(),
h5("Edit data by demographic features below:"),
selectInput('gender2',label = "Gender:",choices = c("Female","Male"),multiple = TRUE,selected = c("Female","Male")),
selectInput('generation2',label = "Generation:",choices = c("Generation Z","Millennials","Generation X","Baby Boomers","Matures"),selected = c("Generation Z","Millennials","Generation X","Baby Boomers","Matures"),multiple = TRUE),
selectInput('ethnicity2',label ='Ethnicity:',choices = c("Asian","Black/African American (non-Hispanic)","Caucasian (non-Hispanic)","Hispanic","Mixed ethnic background","Other"),selected = c("Asian","Black/African American (non-Hispanic)","Caucasian (non-Hispanic)","Hispanic","Mixed ethnic background","Other"),multiple = TRUE),
selectInput('ea2',label = 'Eater Archetype:', choices = c("Affluent Socializers","Bargain Hunters","Busy Balancers","FS Hobbyist","FS Hobbyists","Functional Eater","Functional Eaters","Habitual Matures","Health Enthusiast","Health Enthusiasts"),selected = c("Affluent Socializers","Bargain Hunters","Busy Balancers","FS Hobbyist","FS Hobbyists","Functional Eater","Functional Eaters","Habitual Matures","Health Enthusiast","Health Enthusiasts"),multiple = TRUE)
))
########
ui <-
dashboardPage(
header,
sidebar,
body
)
###########
server<-function(input, output, session){
}
#####
shinyApp(ui = ui, server = server)
Thanks in advance ! :)
I am by no means a CSS expert, but this is how I was able to achieve what you are looking for:
tags$style(".topimg {
margin-left:-30px;
margin-right:-30px;
margin-top:-15px;
}"),
div(class="topimg",img(src="https://dotunroy.files.wordpress.com/2015/05/happy-people.jpg",height="100%", width="100%")),
I had to choose another image, because I did not have the image you used. But luckily I found some volunteers. Look at all those happy people!

Check_MK - Custom check params specified in wato not being given to check function

I am working on a check_mk plugin and can't seem to get the WATO specified params passed to the check function when it runs for one check in particular...
The check param rule shows in WATO
It writes correct looking values to rules.mk
Clicking the Analyze check parameters icon from a hosts service discovery shows the rule as active.
The check parameters displayed in service discovery show the title from the WATO file so it seems like it is associating things correctly.
Running cmk -D <hostname> shows the check as always having the default values though.
I have been staring at it for awhile and am out of ideas.
Check_MK version: 1.2.8p21 Raw
Bulk of check file:
factory_settings["elasticsearch_status_default"] = {
"min": (600, 300)
}
def inventory_elasticsearch_status(info):
for line in info:
yield restore_whitespace(line[0]), {}
def check_elasticsearch_status(item, params, info):
for line in info:
name = restore_whitespace(line[0])
message = restore_whitespace(line[2])
if name == item:
return get_status_state(params["min"], name, line[1], message, line[3])
check_info['elasticsearch_status'] = {
"inventory_function" : inventory_elasticsearch_status,
"check_function" : check_elasticsearch_status,
"service_description" : "ElasticSearch Status %s",
"default_levels_variable" : "elasticsearch_status_default",
"group" : "elasticsearch_status",
"has_perfdata" : False
}
Wato File:
group = "checkparams"
#subgroup_applications = _("Applications, Processes & Services")
register_check_parameters(
subgroup_applications,
"elasticsearch_status",
_("Elastic Search Status"),
Dictionary(
elements = [
( "min",
Tuple(
title = _("Minimum required status age"),
elements = [
Age(title = _("Warning if below"), default_value = 600),
Age(title = _("Critical if below"), default_value = 300),
]
))
]
),
None,
match_type = "dict",
)
Entry in rules.mk from WATO rule:
checkgroup_parameters.setdefault('elasticsearch_status', [])
checkgroup_parameters['elasticsearch_status'] = [
( {'min': (3600, 1800)}, [], ALL_HOSTS ),
] + checkgroup_parameters['elasticsearch_status']
Let me know if any other information would be helpful!
EDIT: pls help
Posted question here as well and the mystery got solved.
I was matching the WATO rule to item None (5th positional arg in the WATO file), but since this check had multiple items inventoried under it (none of which had the id None) the rule was applying to the host, but not to any of the specific service checks.
Fix was to replace that param with:
TextAscii( title = _("Status Description"), allow_empty = True),

sparkline R creating html table

I found package sparkline:https://github.com/htmlwidgets/sparkline
but I have no idea how to create in markdown/html data.frame with sparkcharts.
I know there is an example in link above, but I don't know how to create that data frame in html automatically.
I'm not really sure what your problem is or which data frame you refer to. The example on the link you provide is working perfectly. Try the following steps
Start R Studio
Install the sparkline package if you haven't
library(devtools)
install_github('htmlwidgets/sparkline')
Use File -> New File -> R markdown
Copy in the example from the htmlwidgets in the editor and hit the knitr button.
and you will get an html file with several examples.
I think this is what you are looking for: https://leonawicz.github.io/HtmlWidgetExamples/ex_dt_sparkline.html
you can also find a dummy example here:
R combining data tables DT package and sparkline package box plot with target value
As an example:
Boiled down dummy example as follows (disregard the last column in the data/table)
library(data.table)
library(DT)
library(sparkline)
hist.A<-rnorm(100)
hist.B<-rnorm(100)
hist.C<-rnorm(100)
current.A<-rnorm(1)
current.B<-rnorm(1)
current.C<-rnorm(1)
#whisker should show full range of data
boxval.A<-paste(quantile(hist.A,probs=c(0,0.25,0.5,0.75,1)),collapse = ",")
boxval.B<-paste(quantile(hist.B,probs=c(0,0.25,0.5,0.75,1)),collapse = ",")
boxval.C<-paste(quantile(hist.C,probs=c(0,0.25,0.5,0.75,1)),collapse = ",")
data<-data.frame(Variable=c("A","B","C"),Current=c(current.A,current.B,current.C),boxplot=c(boxval.A,boxval.B,boxval.C))
data$boxWithTarget<-paste(data$boxplot,data$Current,Sep=",")
cd <- list(list(targets = 2, render = JS("function(data, type, full){ return '<span class=sparkSamples>' + data + '</span>' }")))
line_string <- "type: 'line', lineColor: 'black', fillColor: '#ccc', highlightLineColor: 'orange', highlightSpotColor: 'orange'"
box_string <- "type: 'box', raw:true, showOutliers:false,lineColor: 'black', whiskerColor: 'black', outlierFillColor: 'black', outlierLineColor: 'black', medianColor: 'black', boxFillColor: 'orange', boxLineColor: 'black'"
cb = JS("function (oSettings, json) {\n $('.sparkSeries:not(:has(canvas))').sparkline('html', { ",
line_string, " });\n $('.sparkSamples:not(:has(canvas))').sparkline('html', { ",
box_string, " });\n}")
d <- datatable(data.table(data), rownames = FALSE, options = list(columnDefs = cd,
fnDrawCallback = cb))
d$dependencies <- append(d$dependencies, htmlwidgets:::getDependency("sparkline"))
d

Continuing a while loop after error in R

I am trying to use a while loop to download a bunch of JSON files.
They are numbered from 255 to 1. However, some of them are missing (for example, 238.json does not exist).
scheduleurl <- "http://blah.blahblah.com/schedulejsonfile="
i <- 255
while ( i > 0) {
last = paste0(as.character(i), ".json")
path = "/Users/User/Desktop/Temp"
fullpath = paste0(path, last)
ithscheduleurl <- paste0(scheduleurl, as.character(i))
download.file(ithscheduleurl, fullpath)
i <- i - 1
}
I basically want to write my while loop such that if it encounters a nonexisting file (as it will when i = 238), it basically continues to 237 instead of stopping.
I tried the tryCatch() function this way, but it didn't work (keeps trying the same URL) :
while ( i > 0) {
possibleError <- tryCatch({
last = paste0(as.character(i), ".json")
path = "/Users/dlopez/Desktop/Temp"
fullpath = paste0(path, last)
ithscheduleurl <- paste0(scheduleurl, as.character(i))
download.file(ithscheduleurl, fullpath)
i <- i - 1}
, error=function(e) e)
if(inherits(possibleError, "error")) {
next
}
}
Any help would be appreciated!
url.exists from the RCurl package should do the trick.
library(RCurl)
while ( i > 0) {
last = paste0(as.character(i), ".json")
path = "/Users/User/Desktop/Temp"
fullpath = paste0(path, last)
ithscheduleurl <- paste0(scheduleurl, as.character(i))
if (url.exists(ithscheduleurl)) {
download.file(ithscheduleurl, fullpath)
}
i <- i - 1
}