I am having trouble with creating a new variable in dplyr::mutate using a user inputted variable through selectInput in the UI.
gwrdata <- eventReactive(input$rungwr, {
sp_shape <- as(data(), "Spatial")
bwG <- gwr.sel(formula(), data = sp_shape, gweight = gwr.Gauss, verbose = FALSE)
gwrG <- gwr(formula(), data = sp_shape, bandwidth = bwG,
gweight = gwr.Gauss, hatmatrix = TRUE)
sf_gwr <- st_as_sf(gwrG$SDF)
bins <- 3
browser()
sf_gwr <- mutate(sf_gwr, parBin = cut2(sf_gwr[, input$inVar],
g = bins, levels.mean = TRUE))
sf_gwr <- mutate(sf_gwr, sigBin = cut2(localR2, g = bins, levels.mean = TRUE))
bvColors = c("#e8e8e8", "#dfb0d6", "#be64ac", "#ace4e4",
"#a5add3", "#8c62aa", "#5ac8c8", "#5698b9", "#3b4994")
levels(sf_gwr$parBin) <- 1:bins
levels(sf_gwr$sigBin) <- 1:bins
sf_gwr <- mutate(sf_gwr, value = paste(parBin, '-', sigBin, sep = ''))
sf_gwr
})
There are two mutate functions. The process works fine if it is hard coded like it is with localR2. However when using the sf_gwr[,input$inVar] the following error is given.
Evaluation error: no applicable method for 'st_geometry<-' applied to an object of class "list".
Does this have something to do with the subsetting in the mutate function?
Related
The whole function which i need to convert the for loop in to apply for optimization
plans_achievements <- function(pa_m,pa_q){
if(nrow(pa_m)==0 & nrow(pa_q==0)){
df = data.frame(a = c(""), b = c("No Data Available"))
colnames(df)=""
}else{
pa_m= pa_m%>% select(inc,month_year,Plans,Achievements,quarter_year)
colnames(pa_mon)[2] = "Period"
pa_q= pa_q%>% select(inc,quarter_year,Plans,Achievements)
colnames(pa_qtr)[2] = "Period"
df = data.frame(inc=c(""),Period=c(""),Plans=c(""),Achievements=c(""))
for (q in unique(pa_q$Period)){
df1 = pa_q[pa_q$Period==q,]
df1$Period = paste0("<span style=\"color:#288D55\">",df1$Period,"</span>")
df1$Plans = paste0("<span style=\"color:#288D55\">",df1$Plans,"</span>")
df1$Achievements = paste0("<span style=\"color:#288D55\">",df1$Achievements,"</span>")
df = rbind(df,df1)
for (m in unique(pa_m$quarter_year)){
if(m==q){
df2 = pa_m[pa_m$quarter_year==q,][-5]
df = rbind(df,df2)
}
}
}
df = df[-1,]
}
return(df)
}
The apply which i tried
my_fun <- function(q){
df1 = pa_qtr[pa_qtr$Period==q,]
df1$Period = paste0("<span style=\"color:#288D55\">",df1$Period,"</span>")
df1$Plans = paste0("<span style=\"color:#288D55\">",df1$Plans,"</span>")
df1$Achievements = paste0("<span style=\"color:#288D55\">",df1$Achievements,"</span>")
df = rbind(df,df1)
}
df = do.call(rbind,lapply(unique(pa_qtr$Period), my_fun))
my_fun2 <- function(m,my_fun){
if (m == q) {
df2 = pa_mon[pa_mon$qtr_yr == q, ][-5]
df = rbind(df,df2)
}
}
df = do.call(cbind,lapply(unique(pa_mon$qtr_yr), my_fun2))
DT::datatable(plans_achievements(pa_m[pa_m$inc=="vate",],pa_q[pa_q$inc=="vate",]), rownames = F,escape = FALSE,selection=list(mode="single",target="row"),options = list(pageLength = 50,scrollX = TRUE,dom = 'tp',ordering=F,columnDefs = list(list(visible=FALSE, targets=c(0)),list(className = 'dt-left', targets = '_all'))))
Why you get the error comparison is possible only for atomic and list types
I will answer your original question first:
You get the error because you haven't defined q as a variable inside the function my_fun2. Since you haven't defined this variable, R will look for it in the global environment. There R will find the function q() (used to quit R). So you get the error message comparison (1) is possible only for atomic and list types because R thinks you are trying to compare a number m with the function q.
Here is a small example to make it easy to see:
# Run this in a clean environment
m <- 1
m == b # Understandable error message - "b" is not found
m == q # Your error - because R thinks you are comparing m to a function
You fix this error by making sure that q is defined inside your function. Either by creating it inside the function, or by supplying it as an input argument.
A possible solution for your problem
As I understand your code, you want to format, merge and sort the values in pa_q and pa_m, to display them in a html table.
Under is a possible solution, using tidyverse and vectorized operations, rather than a loop or apply functions. Vectorized functions are typically your fastest option in R, as I know you want to optimize your code.
library(dplyr)
plans_achievements <- function(pa_m, pa_q) {
# I've modified the logic a bit: there is no need to wrap the full function in
# an else statement, since we can return early if the data has no rows
if (nrow(pa_m) == 0 && nrow(pa_q == 0)) {
df = data.frame(a = c(""), b = c("No Data Available"))
colnames(df) = ""
return(df)
}
pa_q <-
pa_q %>%
# Select and rename the columns vi need
select(inc, Period = quarter_year, Plans, Achievements, date) %>%
# Format the values
mutate(
Period = paste0("<span style=\"color:#288D55\">", Period,"</span>"),
Plans = paste0("<span style=\"color:#288D55\">", Plans,"</span>"),
Achievements = paste0("<span style=\"color:#288D55\">", Achievements,"</span>")
)
pa_m <-
pa_m %>%
# Select and rename the columns we need
select(inc, Period = month_year, Plans, Achievements, date) #%>%
# Combine the datasets
bind_rows(
pa_q,
pa_m
) %>%
# Make sure that R understand date as a date value
mutate(
date = lubridate::dmy(date)
) %>%
# Sort by date
arrange(desc(date)) %>%
# Remove columns we do not need
select(-date, -inc)
}
DT::datatable(
plans_achievements(
pa_m[pa_m$inc=="vate",],
pa_q[pa_q$inc=="vate",]
),
rownames = FALSE,
escape = FALSE,
selection = list(mode = "single", target = "row"),
options = list(
pageLength = 50,
scrollX = TRUE,
dom = 'tp',
ordering = FALSE,
columnDefs = list(
list(className = 'dt-left', targets = '_all')
)
)
)
Hopefully this solves your problem.
I have constructed multiple protein - protein networks for diseases in shiny app and I ploted them using visnetwork. I found the articulation points for each network and I want to remove them.
My code for a disease looks like this:
output$plot54 <- renderVisNetwork({
alsex <- as.matrix(alsex)
sel1 <- alsex[,1]
sel2 <- alsex[,2]
n10 <- unique(c(sel1,sel2))
n10 <- as.data.frame(n10)
colnames(n10) <- "id"
ed10 <- as.data.frame(alsex)
colnames(ed10) <- c("from", "to", "width")
n10
g <- graph_from_data_frame(ed10)
articulation.points(g)
nodes4 <- data.frame(n10, color = ifelse(n10$id=="CLEC4E"|n10$id=="ACE2"|n10$id=="MYO7A"|n10$id=="HSPB4"
|n10$id=="EXOSC3"|n10$id=="RBM45"|n10$id=="SPAST"|n10$id=="ALMS1"|n10$id=="PIGQ"
|n10$id=="CDC27"|n10$id=="GFM1"|n10$id=="UTRN"|n10$id=="RAB7B"|n10$id=="GSN"|n10$id=="VAPA"|n10$id=="GLE1"
|n10$id=="FA2H"|n10$id=="HSPA4"|n10$id=="SNCA"|n10$id=="RAB5A"|n10$id=="SETX","red","blue"))
visNetwork(nodes4, ed10, main = "Articulation Points") %>%
visNodes (color = list(highlight = "pink"))%>%
visIgraphLayout()%>%
visOptions(highlightNearest = list(enabled = T, hover = T),
nodesIdSelection = T)%>%
visInteraction(keyboard = TRUE)
})
observe({
input$delete54
visNetworkProxy("plot54") %>%
visRemoveNodes(id="CLEC4E")%>%visRemoveEdges(id = "CLEC4E")%>%
visRemoveNodes(id="ACE2")%>%visRemoveEdges(id = "ACE2")%>%
visRemoveNodes(id="MYO7A")%>%visRemoveEdges(id = "MYO7A")%>%
visRemoveNodes(id="HSPB4")%>%visRemoveEdges(id = "HSPB4")%>%
visRemoveNodes(id="EXOSC3")%>%visRemoveEdges(id = "EXOSC3")%>%
visRemoveNodes(id="RBM45")%>%visRemoveEdges(id = "RBM45")%>%
visRemoveNodes(id="SPAST")%>%visRemoveEdges(id = "SPAST")%>%
visRemoveNodes(id="ALMS1")%>%visRemoveEdges(id = "ALMS1")%>%
visRemoveNodes(id="PIGQ")%>%visRemoveEdges(id = "PIGQ")%>%
visRemoveNodes(id="CDC27")%>%visRemoveEdges(id = "CDC27")%>%
visRemoveNodes(id="GFM1")%>%visRemoveEdges(id = "GFM1")%>%
visRemoveNodes(id="UTRN")%>%visRemoveEdges(id = "UTRN")%>%
visRemoveNodes(id="RAB7B")%>%visRemoveEdges(id = "RAB7B")%>%
visRemoveNodes(id="GSN")%>%visRemoveEdges(id = "GSN")%>%
visRemoveNodes(id="VAPA")%>%visRemoveEdges(id = "VAPA")%>%
visRemoveNodes(id="GLE1")%>%visRemoveEdges(id = "GLE1")%>%
visRemoveNodes(id="FA2H")%>%visRemoveEdges(id = "FA2H")%>%
visRemoveNodes(id="HSPA4")%>%visRemoveEdges(id = "HSPA4")%>%
visRemoveNodes(id="SNCA")%>%visRemoveEdges(id = "SNCA")%>%
visRemoveNodes(id="RAB5A")%>%visRemoveEdges(id = "RAB5A")%>%
visRemoveNodes(id="SETX")%>%visRemoveEdges(id = "SETX")
})
Using
g <- graph_from_data_frame(ed10)
articulation.points(g)
I found the articulation points, and I marked them with red color using ifelse as you can see in nodes4 vector.
My questions:
How to shorten my code in ifelse using loop, so I don't have to write the articullation points one by one manually.
How to shorten my code in visRemoveNodes and visRemoveEdges using loop, so I don't have to write them one by one manually as well.
Crossed posted at:
https://community.rstudio.com/t/how-to-shorten-code-for-visremovenodes-using-loop/72506
The answer for the second question is:
observe({
l <- c("CLEC4E","ACE2", "MYO7A", "HSPB4", "EXOSC3", "RBM45","SPAST","ALMS1",
"PIGQ","CDC27","GFM1","UTRN",
"RAB7B", "GSN", "VAPA", "GLE1","FA2H","HSPA4",
"SNCA","RAB5A","SETX") #we put all genes that we want to delete in a vector
for (i in l){
input$delete54
visNetworkProxy("plot54")%>%
visRemoveNodes(id= i)%>%visRemoveEdges(id = i)
}
})
I want to create a new stat which calculates interval-censored survival with survival::survfit.formula. But I seem to get a wrong data frame in the compute_group function, and I struggle to find the reason for it.
Creating a data frame with exactly the same code "outside" and using geom_path (which I want to use for the stat), results in a fine result (see expected result). - it seems as if survfit.formula() is creating NAs within compute_group(), but I don't understand why.
setting /adding na.rm = TRUE/FALSE does not change anything.
Also using Inf instead of NA for time2 does not help.
library(ggplot2)
library(survival)
set.seed(42)
testdf <- data.frame(time = sample(30, replace = TRUE), time2 = c(20, 10, 10, 30, rep(NA, 26)))
fit_icens <-
survival::survfit.formula(
survival::Surv(time = time, time2 = time2, type = "interval2") ~ 1,
data = testdf
)
Expected result
path <- data.frame(time = fit_icens$time, time2= fit_icens$surv)
ggplot(path, aes(x = time, y = time2)) +
geom_path() +
coord_cartesian(ylim = c(0, 1))
Failing
StatIcen <- ggplot2::ggproto("StatIcen", Stat,
required_aes = c("time", "time2"),
compute_group = function(data, scales) {
fit_icens <-
survival::survfit.formula(
survival::Surv(time = data$time, time2 = data$time2, type = "interval2") ~ 1,
data = data
)
path <- data.frame(x = fit_icens$time, y = fit_icens$surv)
path
}
)
stat_icen <- function(mapping = NULL, data = NULL, geom = "path",
position = "identity", show.legend = NA,
inherit.aes = TRUE, ...) {
layer(
stat = StatIcen, data = data, mapping = mapping, geom = geom,
position = position, show.legend = show.legend, inherit.aes = inherit.aes,
params = list(...)
)
}
ggplot(testdf, aes(time = time, time2 = time2)) +
stat_icen()
#> Warning: Removed 26 rows containing non-finite values (stat_icen).
Created on 2020-05-04 by the reprex package (v0.3.0)
Great question Tjebo, thanks for posting.
As you have already figured out, the problem is that the NA values are being stripped out of your data before it is passed to compute_group. The Extending ggplot vignette doesn't mention this, but your data is first passed through the compute_layer member function of your ggproto object. Since you haven't defined a compute_layer method, your StatIcen class inherits the method from the class ggplot2::Stat.
If you look at the source code for this method in ggplot2::Stat$compute_layer, you will see this is where your NA values are stripped out, using the remove_missing function, which removes rows in your data frame with missing values in any of the named columns. Presumably, you still want NA values removed if they appear in your time column, but not if they appear in time2.
So all I have done here is to copy the source code from Stat$compute_layer and adjust the remove_missing call slightly, then make it a member of StatIcen:
StatIcen <- ggplot2::ggproto("StatIcen", Stat,
required_aes = c("time", "time2"),
compute_group = function(data, scales){
fit_icens <- survival::survfit.formula(
survival::Surv(time = data$time, time2 = data$time2,
type = "interval2") ~ 1, data = data)
data.frame(x = fit_icens$time, y = fit_icens$surv)
},
compute_layer = function (self, data, params, layout)
{
ggplot2:::check_required_aesthetics(self$required_aes, c(names(data),
names(params)), snake_class(self))
data <- remove_missing(data, params$na.rm, "time",
ggplot2:::snake_class(self), finite = TRUE)
params <- params[intersect(names(params), self$parameters())]
args <- c(list(data = quote(data), scales = quote(scales)), params)
ggplot2:::dapply(data, "PANEL", function(data) {
scales <- layout$get_scales(data$PANEL[1])
tryCatch(do.call(self$compute_panel, args),
error = function(e) {
warning("Computation failed in `",
ggplot2:::snake_class(self),
"()`:\n", e$message, call. = FALSE)
ggplot2:::new_data_frame()
})
})
}
)
So now we get:
ggplot(testdf, aes(time = time, time2 = time2)) + stat_icen()
I need to get the dataframe from a function in rShiny server. But that function returns a Plot and the return value cannot be changed as the plots are used in the future use.
have not pasted the whole code as its like 200 lines each for the function and also for the rshiny server.
Hist_Read_data4 <- full_join(Hist_Read_data1,Hist_Read_data_opst, by = c("timestamp"))%>%
arrange(timestamp)%>%
subset(timestamp >= as.POSIXct(start_timestamp, origin = "1970-01-01") & timestamp <= as.POSIXct(end_timestamp, origin = "1970-01-01"))%>%
mutate(value.y = na.locf(value.y, na.rm = FALSE))%>%
mutate(value.y = fct_explicit_na(value.y, na_level = "None"))%>%
mutate(value.x = na.locf(value.x, na.rm=FALSE))%>%
mutate(new_value = abs(value.x - lag(value.x)))%>%
mutate(new_value = replace_na(new_value, 0))%>%
mutate(new_value = cumsum(new_value))
plot <- ggplot() +
geom_path(data = Hist_Read_data4, mapping = aes(x = timestamp, y=value.x, color = value.y), na.rm = TRUE, linejoin = 'round' , size=1.5, group = 1)
//Hist_Read_data4 is the dataframe which i need to return//
//plot is the return value of the function//
output$HoverText <- renderText({
coordinfo <- input$PlotHover
nearpts <- nearPoints(Hist_Read_data4, coordinfo, xvar= "timestamp", yvar = "value.y", threshold = 20)
})
need Hist_Read_data4 in inside nearpoints. But it cannot be accessed as its inside a function named chooseDevice() in a separate script file named data_funcs.R
I do not want to change the return value of the chooseDevice function from plot to returning this dataframe as it will complicate the whole code and 2 months work will be wasted.
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```