Related
I don't get similar results when I use the same data and models using mlr and mlr3. Also I find mlr runs at least 20-fold faster. I used lung data from survival and I was able to replicate the difference in computation speed and results since I can't share my data.
mlr was completed in 1 min with C-index generally low compared to mlr3 that took 21 min to complete with C-index being much higher despite using same data, same preprocessing, same model and setting seed.
library(tidyverse)
library(tidymodels)
library(PKPDmisc)
library(mlr)
library(parallelMap)
library(survival)
# Data and Data Splitting
data = as_tibble(lung) %>%
mutate(status = if_else(status==1, 0, 1),
sex = factor(sex, levels = c(1:2), labels = c("male", "female")),
ph.ecog = factor(ph.ecog))
na <- sample(1:228, 228*0.1)
data$sex[na] <- NA
data$ph.ecog[na]<- NA
set.seed(123)
split <- data %>% initial_split(prop = 0.8, strata = status)
train <- split %>% training()
test <- split %>% testing()
# Task
task = makeSurvTask(id = "Survival", data = train, target = c("time", "status"))
# Resample
# For model assessment before external validation on test data
set.seed(123)
outer_cv = makeResampleDesc("CV", iter=4, stratify.cols = c("status")) %>%
makeResampleInstance(task)
# For feature selection and parameter tuning
set.seed(123)
inner_cv = makeResampleDesc("CV", iter=4, stratify.cols = c("status"))
# Learners
cox1 = makeLearner(id = "COX1", "surv.coxph") %>%
makeImputeWrapper(classes = list(factor = imputeMode(), numeric = imputeMedian()),
# Create dummy variable for factor features
dummy.classes = "factor") %>%
makePreprocWrapperCaret(ppc.center = TRUE, ppc.scale = TRUE) %>%
makeFeatSelWrapper(resampling = inner_cv, show.info = TRUE,
control = makeFeatSelControlSequential(method = "sfs"))
cox_lasso = makeLearner(id = "COX LASSO", "surv.glmnet") %>%
makeImputeWrapper(classes = list(factor = imputeMode(), numeric = imputeMedian()),
# Create dummy variable for factor features
dummy.classes = "factor") %>%
# Normalize numeric features
makePreprocWrapperCaret(ppc.center = TRUE, ppc.scale = TRUE) %>%
makeTuneWrapper(resampling = inner_cv, show.info = TRUE,
par.set = makeParamSet(makeNumericParam("lambda",lower = -3, upper = 0,
trafo = function(x) 10^x)),
control = makeTuneControlGrid(resolution = 10L))
cox_net = makeLearner(id = "COX NET", "surv.glmnet") %>%
makeImputeWrapper(classes = list(factor = imputeMode(), numeric = imputeMedian()),
# Create dummy variable for factor features
dummy.classes = "factor") %>%
# Normalize numeric features
makePreprocWrapperCaret(ppc.center = TRUE, ppc.scale = TRUE) %>%
makeTuneWrapper(resampling = inner_cv, show.info = TRUE,
par.set = makeParamSet(makeNumericParam("alpha", lower = 0, upper = 1,
trafo = function(x) round(x,2)),
makeNumericParam("lambda",lower = -3, upper = 1,
trafo = function(x) 10^x)),
control = makeTuneControlGrid(resolution = 10L))
# Benchmark
# parallelStartSocket(4)
start_time <- Sys.time()
set.seed(123)
mlr_bmr = benchmark(learners = list(cox1, cox_lasso, cox_net),
tasks = task,
resamplings = outer_cv,
keep.extract= TRUE,
models = TRUE)
end_time <- Sys.time()
mlr_time = end_time - start_time
# parallelStop()
mlr_res <- getBMRPerformances(mlr_bmr, as.df = TRUE) %>%
select(Learner = learner.id, Task = task.id, Cindex = cindex) %>%
mutate(Color_Package = "mlr",
Learner = word(str_replace(Learner, "\\.", " "), 1, -2))
##################################################################
library(mlr3verse)
# Task
task2 = TaskSurv$new(id = "Survival2", backend = train, time = "time", event = "status")
task2$col_roles$stratum = c("status")
# Resmaple
set.seed(123)
outer_cv2 = rsmp("cv", folds = 4)$instantiate(task2)
# For feature selection and parameter tuning
set.seed(123)
inner_cv2 = rsmp("cv", folds = 4)
# Learners
preproc = po("imputemedian", affect_columns = selector_type("numeric")) %>>%
po("imputemode", affect_columns = selector_type("factor")) %>>%
po("scale") %>>%
po("encode")
cox2 = AutoFSelector$new(learner = as_learner(preproc %>>%
lrn("surv.coxph")),
resampling = inner_cv2,
measure = msr("surv.cindex"),
terminator = trm("none"), # need to increase later
fselector = fs("sequential", strategy = "sfs")) # sfs is the default
cox2$id = "COX1"
cox_lasso2 = AutoTuner$new(learner = as_learner(preproc %>>%
lrn("surv.glmnet",
lambda = to_tune(p_dbl(lower = -3, upper = 0,
trafo = function(x) 10^x)))),
resampling = inner_cv2,
measure = msr("surv.cindex"),
terminator = trm("none"),
tuner = tnr("grid_search", resolution = 10))
cox_lasso2$id = "COX LASSO"
cox_net2 = AutoTuner$new(learner = as_learner(preproc %>>%
lrn("surv.glmnet",
alpha = to_tune(p_dbl(lower = 0, upper = 1)),
lambda = to_tune(p_dbl(lower = -3, upper = 1,
trafo = function(x) 10^x)))),
resampling = inner_cv2,
measure = msr("surv.cindex"),
terminator = trm("none"),
tuner = tnr("grid_search", resolution = 10))
cox_net2$id = "COX NET"
# Benchmark
desgin = benchmark_grid(tasks = task2,
learners = c(cox2, cox_lasso2, cox_net2),
resamplings = outer_cv2)
# future::plan("multisession")
# Error: Output type of PipeOp select during training (Task) incompatible with input type of PipeOp surv.coxph (TaskSurv)
start_time <- Sys.time()
set.seed(123)
mlr3_bmr = mlr3::benchmark(desgin)
end_time <- Sys.time()
mlr3_time = end_time - start_time
mlr3_res <- as.data.table(mlr3_bmr$score()) %>%
select(Task=task_id, Learner=learner_id, Cindex=surv.harrell_c) %>%
mutate(Color_Package = "mlr3")
mlr_res %>%
bind_rows(mlr3_res) %>%
ggplot(aes(Learner, Cindex, fill= Color_Package )) +
geom_boxplot(position=position_dodge(.8)) +
stat_summary(fun= mean, geom = "point", aes(group = Color_Package ),
position=position_dodge(.8), size = 3) +
labs(x="", y = " C-Index") +
theme_bw() + base_theme() + theme(legend.position = "top")
I am using the following rmarkdown code, using xelatex engine:
access <- function(x, ...) {
x <- delete_part(x)
x <- colformat_double(x, big.mark = "'", decimal.mark = ",")
x <- set_table_properties(x, layout = "autofit")
x <- border_remove(x)
std_border <- fp_border_default(width = 1, color = "black")
x <- border_outer(x, part="all", border = std_border )
x <- border_inner_h(x, border = std_border, part="all")
x <- border_inner_v(x, border = std_border, part="all")
autofit(x)
}
firstc <- c("Field:","Table:","Sort:","Show:","Criteria:","Or:")
secondc <- c("Field:","Table:","Sort:","Show:","Criteria:","Or:")
```
```{r echo=FALSE}
tabela <- data.frame(firstc,secondc)
ft <- flextable(tabela)
ft <- access(ft)
ft <- hline_top(ft)
ft <- fit_to_width(ft, max_width = 4)
ft <- set_table_properties(ft, layout = "autofit", width = 1)
ft
```
However, the top hline does not show up in the PDF output.
Any ideas?
I'm using a datatable in a shiny app with custom coloring of the cells. This is done in html (each cell is a div) and by telling DT to not escape these specific columns.
It looks like this with DT :
screenshot
My issue is that I would like the coloring to take the entire height of each cell so that there is no margins. If I could have the different cell colors to touch each other that would be great.
I have try to add margin: 0px; padding: 0px; but it makes no difference.
I've also tried to use the formatstyle from DT to reduce the row height like so :
formatStyle( 0, target = 'row', lineHeight = '80%')
and the result looks like this :
screenshot 2
I'm currently trying with padding: 0px;margin-top:0px;margin-right:0px;margin-bottom:0px;margin-left:0px; but it does not work any better.
It looks to me that this is a margin from DT rather than my div since whatever I try in my div style, I've always the same margins between the colors and the row height limits. The only thing is I do not know how to control it.
Would anyone know how to achieve such a result ?
Thanks ahead of time for your help.
Code used :
for (c in colnames(ranking)[10:13]) {
ranking <- ranking %>%
filter(param %in% input$param) %>%
arrange_(.dots = c) %>%
mutate(!!paste0(c, "_rk") := 1:nrow(ranking %>% filter(param %in% input$param)))
tmp <- ranking %>%
arrange_(.dots = c) %>%
select_(.dots = c)
max <- tmp %>% tidyr::drop_na() %>% .[, 1] %>% max()
min <- tmp %>% tidyr::drop_na() %>% .[, 1] %>% min()
range <- max - min
brks <- vector(length = colors)
for (i in 1:colors) {
brks[i] <- i^pracma::bisect(function(x) range^(1/x) - (colors + 1), 1, 5)$root %>% round(2) + min - 2
}
tmp <- tmp %>%
mutate(brks = ifelse(is.na(tmp[, 1]),
NA,
cut(tmp %>% tidyr::drop_na() %>% .[, 1], brks)))
colfunc <- colorRampPalette(c("#c31432", "#ffc500", "#edde5d", "white"))
clrs <- colfunc(colors + 1)
tmp_nrow <- tmp %>% nrow()
for (i in 1:tmp_nrow) {
row <- which(tmp[i, 1] == ranking[,c])
r <- clrs[tmp[i, 2]] %>% col2rgb() %>% .[1]
g <- clrs[tmp[i, 2]] %>% col2rgb() %>% .[2]
b <- clrs[tmp[i, 2]] %>% col2rgb() %>% .[3]
tmp[i, 1] <- paste0("<center><div style='background: ", "radial-gradient(rgba(", r, ",", g, ",", b, ",", "0), rgba(", r, ",", g, ",", b, ",", "0.25), rgba(", r, ",", g, ",", b, ",", "1)", ")", "; border: solid 0px;font-family: \"Interstate Black\";font-weight: bolder;padding: 0;margin: 0;'>",
tmp[i, 1],
"</div></center>")
ranking[row,paste0(c, "_coloring")] <- tmp[i, 1]
}
}
ranking_m <- as.matrix(ranking %>%
filter(param %in% input$param) %>%
select(4, 47, 40, 38, 31, 32, 41, 42, 43, 44))
DT::datatable(ranking_m,
escape = c(TRUE, FALSE, rep(FALSE, 8)),
filter = 'top',
extensions = list('Responsive' = NULL),
options = list(pageLength = 25,
lengthMenu = c(10, 25, 50, 100),
columnDefs = list(list(width = '400px', targets = 0),
list(width = '25px', targets = 1),
list(className = 'dt-center', targets = 2:9)))) #%>%
# formatStyle( 0, target = 'row', lineHeight = '80%')
The background CSS must be set to the cells, not to the cells contents. This can be achieved with formatStyle. Here is an example with random colors:
library(DT)
dat <- iris[1:5,]
ncols <- ncol(dat)
# background for column 1
r <- sample.int(256, 5, replace = TRUE) - 1L
g <- sample.int(256, 5, replace = TRUE) - 1L
b <- sample.int(256, 5, replace = TRUE) - 1L
dat$RGB1 <- sprintf("radial-gradient(rgba(%s,%s,%s,0),rgba(%s,%s,%s,0.25),rgba(%s,%s,%s,1))",
r, g, b, r, g, b, r, g, b)
# background for column 2
r <- sample.int(256, 5, replace = TRUE) - 1L
g <- sample.int(256, 5, replace = TRUE) - 1L
b <- sample.int(256, 5, replace = TRUE) - 1L
dat$RGB2 <- sprintf("radial-gradient(rgba(%s,%s,%s,0),rgba(%s,%s,%s,0.25),rgba(%s,%s,%s,1))",
r, g, b, r, g, b, r, g, b)
# background for column 4
r <- sample.int(256, 5, replace = TRUE) - 1L
g <- sample.int(256, 5, replace = TRUE) - 1L
b <- sample.int(256, 5, replace = TRUE) - 1L
dat$RGB4 <- sprintf("radial-gradient(rgba(%s,%s,%s,0),rgba(%s,%s,%s,0.25),rgba(%s,%s,%s,1))",
r, g, b, r, g, b, r, g, b)
datatable(dat,
options =
list(
columnDefs =
list(
list(visible = FALSE, targets = ncols + 1:3),
list(className = "dt-center", targets = 1:ncols)
)
)) %>%
formatStyle(1, valueColumns = ncols+1, background = JS("value")) %>%
formatStyle(2, valueColumns = ncols+2, background = JS("value")) %>%
formatStyle(4, valueColumns = ncols+3, background = JS("value")) %>%
formatStyle(1:ncols, `font-family` = "Interstate Black") %>%
formatStyle(1:ncols, fontWeight = "bolder")
I am using R 3.5.1 on OS Windows 7 x64.
My package versions are:
flextable: 0.5.1
officer: 0.3.2
tidyverse: 1.2.1
tidyr: 0.8.2
I am trying to create and then print multiple flextables in a single chunk to Word. I also do not want the actual R code in the Word Doc, so I've set echo = FALSE. However, I've run into something strange.
If I use the following code (echo = T):
```{r, echo = F, warning=FALSE, message=FALSE}
library(tidyverse)
library(flextable)
library(officer)
```
```{r, echo = T}
iris_data <- head(iris, n = 10)
iris_data_ft <- iris_data %>% flextable() %>%
hline(part = 'header', border = fp_border(color = "black", width = 3)) %>%
align(align ='center', part = 'all') %>%
align(j = 1, align ='left', part = 'all') %>%
add_header_lines('this is a test')
iris_data_ft
iris_data2 <- tail(iris, n = 10)
iris_data2_ft <- iris_data2 %>% flextable() %>%
hline(part = 'header', border = fp_border(color = "black", width = 3)) %>%
align(align ='center', part = 'all') %>%
align(j = 1, align ='left', part = 'all') %>%
add_header_lines('this is a test')
iris_data2_ft
```
I get the following output of proper flextables in Word:
If I use the exact same code, but with echo = F:
```{r, echo = F}
iris_data <- head(iris, n = 10)
iris_data_ft <- iris_data %>% flextable() %>%
hline(part = 'header', border = fp_border(color = "black", width = 3)) %>%
align(align ='center', part = 'all') %>%
align(j = 1, align ='left', part = 'all') %>%
add_header_lines('this is a test')
iris_data_ft
iris_data2 <- tail(iris, n = 10)
iris_data2_ft <- iris_data2 %>% flextable() %>%
hline(part = 'header', border = fp_border(color = "black", width = 3)) %>%
align(align ='center', part = 'all') %>%
align(j = 1, align ='left', part = 'all') %>%
add_header_lines('this is a test')
iris_data2_ft
```
I get the following in Word (this goes on for 58 pages):
Finally, if I split the one chunk for the two flextables into two separate chunks and set echo = F:
```{r, echo = F}
iris_data <- head(iris, n = 10)
iris_data_ft <- iris_data %>% flextable() %>%
hline(part = 'header', border = fp_border(color = "black", width = 3)) %>%
align(align ='center', part = 'all') %>%
align(j = 1, align ='left', part = 'all') %>%
add_header_lines('this is a test')
iris_data_ft
```
```{r, echo = F}
iris_data2 <- tail(iris, n = 10)
iris_data2_ft <- iris_data2 %>% flextable() %>%
hline(part = 'header', border = fp_border(color = "black", width = 3)) %>%
align(align ='center', part = 'all') %>%
align(j = 1, align ='left', part = 'all') %>%
add_header_lines('this is a test')
iris_data2_ft
```
The tables render just fine:
While I don't mind separating the flextables into different chunks, I am wondering why this is happening. Any guidance would be greatly appreciated. Thanks!
Here is a workaround:
---
title: "Untitled"
output: word_document
---
```{r setup, include=FALSE}
knitr::opts_chunk$set(echo = TRUE)
library(flextable)
```
```{r echo=FALSE, results='asis'}
library(htmltools)
ft <- flextable(head(iris))
for(i in 1:3){
cat("```{=openxml}\n")
cat(format(ft, type = "wml"), "\n")
cat("```\n")
}
```
I guess this issue is solved with newer versions of flextable already. If I put the code following two chunks into a .Rmd document and knit to word it compiles without problems and shows tables, even if put into one chunk with echo = F. Just wanted to add: In some cases it might be helpful to add results='asis' - the 'as is'-option (raw Markdown parsing) - to your chunk header to prevent errors when parsing tables, check: bookdown.org/results-as-is.
```{r, echo = F, warning=FALSE, message=FALSE}
library(tidyverse)
library(flextable)
library(officer)
```
```{r, echo = F}
iris_data <- head(iris, n = 10)
iris_data_ft <- iris_data %>% flextable() %>%
hline(part = 'header', border = fp_border(color = "black", width = 3)) %>%
align(align ='center', part = 'all') %>%
align(j = 1, align ='left', part = 'all') %>%
add_header_lines('this is a test')
iris_data_ft
iris_data2 <- tail(iris, n = 10)
iris_data2_ft <- iris_data2 %>% flextable() %>%
hline(part = 'header', border = fp_border(color = "black", width = 3)) %>%
align(align ='center', part = 'all') %>%
align(j = 1, align ='left', part = 'all') %>%
add_header_lines('this is a test')
iris_data2_ft
```
I am new to the leaflet package.
I am trying to draw two types of polygons and let the user select them and see the borders. These polygons have labels and I want to display them by default. At the moment the labels are displayed only on mouse hover.
Basically what I want is to let the user search for the polygon label on the map.
Given below is my code.
shp <- readOGR(dsn = 'shapes'
,layer = 'SAB')
postcode <- readOGR(dsn = 'shapes'
,layer = 'Postcode')
CRS_WGS84 <- '+proj=longlat +datum=WGS84 +no_defs +ellps=WGS84 +towgs84=0,0,0'
t_shp <- spTransform(shp, CRS(CRS_WGS84))
sab_shp <- raster::aggregate(t_shp, by='SMALL_AREA')
dat <- data.table(shp#data)
sabLabels <- sprintf('<strong>SAB: %s', t_shp$SMALL_AREA) %>% lapply(HTML)
postcode <- readOGR(dsn = 'shapes'
,layer = 'Postcode')
CRS_WGS84 <- '+proj=longlat +datum=WGS84 +no_defs +ellps=WGS84 +towgs84=0,0,0'
t_shp2 <- spTransform(postcode, CRS(CRS_WGS84))
postcode_shp <- raster::aggregate(t_shp2, by='RoutingKey')
dat2 <- data.table(postcode#data)
postcodeLabels <- sprintf('<strong>SAB: %s', t_shp2$RoutingKey) %>% lapply(HTML)
leaflet() %>%
addTiles() %>% #using default does not allow html export to include the underlying
#OSM layer
addProviderTiles('OpenStreetMap.Mapnik') %>%
addPolygons( data = t_shp
,stroke = T
,fillColor = 'grey'
,fillOpacity = 0.2
,color = 'blue'
,weight = 0.5
,label = sabLabels
,group = 'SABS'
,highlightOptions = highlightOptions(color = "blue", weight = 7,
bringToFront = TRUE)
#,labelOptions = labelOptions(noHide = TRUE, textOnly = TRUE, opacity = 0.5 , textsize='15px')
) %>%
addPolygons( data = t_shp2
,stroke = T
,fillOpacity = 0
,color = 'black'
,weight = 1.5
,label = postcodeLabels
,group = 'PostCodes'
) %>%
addLayersControl(
overlayGroups = c(
'SABS'
,'PostCodes'
)
,options = layersControlOptions((collapsed = F))
)