Problem with survival function in Shiny App - r

Recently I'm using the survival package in R, in order to be able to better measure the waiting time of patients in the Emergency Department of my Hospital, what I have achieved. However, it's complex to show the results and that can be understood by third parties from RStudio, so I'm developing a Shiny App to show the results without having to show the code and be able to modify certain elements quickly
When I create the app, I have the problem that when I request that you build a dataframe with the quantiles, I get the error: "Error in rep: invalid 'times' argument" in R#200. I have reviewed the code on multiple occasions, but I still can't find a solution. I enclose the complete code
Thank you
ui <- fluidPage(
titlePanel("Prototipo Tiempos de Urgencia"),
sidebarLayout(
sidebarPanel(
selectInput(inputId = "triage",
label = "Triage",
choices =c("Todos",listadotriage),
selectize = FALSE,
selected = "Todos"),
selectInput(inputId = "tiempo",
label = "Tiempo a analizar",
choices = c("Diferencia entre Hora de atención y hora de triage" = "60",
"Diferencia ente hora de atencón y hora de admisión" = "61",
"Diferencia ente hora de atencón y hora de alta" = "62",
"Diferencia ente hora de admision y hora de alta" = "63",
"Diferencia ente hora de admision y hora de triage" = "64"),
selectize = FALSE,
selected = "Diferencia entre Hora de atención y hora de triage"),
selectInput(inputId = "atencion",
label = "Área Atención",
choices = c("Todos",listadoatencion),
selectize = FALSE,
selected = "Todos"),
selectInput(inputId = "alta",
label = "Tipo de Alta",
choices = c("General" = "74",
"Hospitalizado" = "72",
"Altas" = "73"),
multiple = FALSE,
selected = "General"),
dateRangeInput(inputId = "fecha",
label = "Intervalo de fechas",
format = "dd-mm-yyyy",
start = "2019-11-01",
end = "2019-11-30",
weekstart = 1,
language= "es",
separator = "a")
),
mainPanel = dataTableOutput(outputId = "tabla1")
))
server <- function(input, output) {
output$tabla1 <- renderDataTable({
if (input$triage=="Todos") {
dat1<-subset(dat1,ifelse(input$atencion!="Todos",dat1$AREA_ATENCION==input$atencion & dat1$fechanormal>=input$fecha[1] & dat1$fechanormal<=input$fecha[2],
dat1$fechanormal>=input$fecha[1] & dat1$fechanormal<=input$fecha[2]))
timesevent<-as.integer(input$tiempo)
event<-as.integer(input$alta)
dat3<-dat1[,c(30,timesevent,event)]
gral<-Surv(dat3[[2]] ,event= as.numeric(dat3[[3]]))
fit1a<-survfit(gral ~ Medico, data = dat3)
d1<-as.data.frame(quantile(fit1a,c(0.25,0.5,0.75,0.9,1),conf.int = FALSE)) # estadísticas sobre tiempo de demora según modelo
data1<-as.data.frame(fit1a$strata)
setDT(data1,keep.rownames = TRUE)
data1$rn<-gsub("Medico=","",data1$rn)
colnames(data1)<-c("Médico","Consultas")
setDT(d1,keep.rownames = TRUE)[]
d1$rn<-gsub("Medico=","",d1$rn)
colnames(d1)<-c("Médico","P.25","P.50","P.75","P.90","P.100")
datatotal1<-merge(data1,d1,by="Médico")
datatable(data=datatota1l,caption =paste("Tiempos de atención en Servicio de Urgencia por Médico, por Atención en Servicio",input$atencion,"durante","el período",format(input$fecha[1], format= "%d-%m-%Y"),"a",format(input$fecha[2], format= "%d-%m-%Y"), sep=" "),
rownames = FALSE,extensions= "Buttons",options=list(pageLength=40,dom="Bfrtip", buttons = c("print")) )
} else {
dat1<-subset(dat1,dat1$Triage==input$triage)
dat1<-subset(dat1,ifelse(input$atencion!="Todos",dat1$AREA_ATENCION==input$atencion & dat1$fechanormal>=input$fecha[1] & dat1$fechanormal<=input$fecha[2],
dat1$fechanormal>=input$fecha[1] & dat1$fechanormal<=input$fecha[2]))
timesevent<-as.integer(input$tiempo)
event<-as.integer(input$alta)
dat3<-dat1[,c(30,timesevent,event)]
gral<-Surv(dat3[[2]] ,event= as.numeric(dat3[[3]])) ~ Medico
fit1b<-survfit(gral ~ Medico, data = dat3)
d2<-as.data.frame(quantile(fit1b,c(0.25,0.5,0.75,0.9,1),conf.int = FALSE)) # estadísticas sobre tiempo de demora según modelo
data2<-as.data.frame(fit1b$strata)
setDT(data2,keep.rownames = TRUE)
data2$rn<-gsub("Medico=","",data2$rn)
colnames(data2)<-c("Médico","Consultas")
setDT(d2,keep.rownames = TRUE)[]
d2$rn<-gsub("Medico=","",d2$rn)
colnames(d2)<-c("Médico","P.25","P.50","P.75","P.90","P.100")
datatotal2<-merge(data2,d1,by="Médico")
datatable(data=datatotal2,caption =paste("Tiempos de atención en Servicio de Urgencia por Médico, por Categorización",input$triage,"por Atención en Servicio",input$atencion,"durante","el período",format(input$fecha[1], format= "%d-%m-%Y"),"a",format(input$fecha[2], format= "%d-%m-%Y"), sep=" "),
rownames = FALSE,extensions= "Buttons",options=list(pageLength=40,dom="Bfrtip", buttons = c("print")) )
}
})
}
shinyApp(ui = ui, server = server)```

I resolved!!!!
I changed the next lines
dat1<-subset(dat1,ifelse(input$atencion!="Todos",dat1$AREA_ATENCION==input$atencion & dat1$fechanormal>=input$fecha[1] & dat1$fechanormal<=input$fecha[2],
dat1$fechanormal>=input$fecha[1] & dat1$fechanormal<=input$fecha[2]))
```
for the next lines:
```
dat3<-subset(dat3,dat3$fechanormal>=input$fecha[1] & dat3$fechanormal<=input$fecha[2])
ifelse(input$atencion!="Todos",dat3<-subset(dat3,dat3$AREA_ATENCION==input$atencion),NA)
```
Regards!!!

Related

How to introduce non-numeric arguments in the same vector with numeric arguments for a reactable?

and thanks for reading me again
I am working with a table in which in the "Valor" column I have a vector with numbers from 0 to 1 for bars with percentages as seen in the following image:
But I would like that in the fields where there is a value of "0%" instead of having the progress bar it would simply have the text "nd". Is there a way to do that?
The code used is the following:
library(dplyr)
library(reactable)
library(htmltools)
# df for the table
Objetivo_1 <- data.frame(
Estrategia = c("1.1", "1.2", "1.3", "1.4", "1.5", "1.6"),
`Nombre del indicador` = c("Porcentaje de indicadores de la estrategia 1.1
que cumplen con la tendencia esperada entre el periodo
actual y el periodo inmediato anterior",
"Porcentaje de indicadores de la estrategia 1.2
que cumplen con la tendencia esperada entre el periodo
actual y el periodo inmediato anterior",
"Porcentaje de indicadores de la estrategia 1.3
que cumplen con la tendencia esperada entre el periodo
actual y el periodo inmediato anterior",
"Porcentaje de indicadores de la estrategia 1.4
que cumplen con la tendencia esperada entre el periodo
actual y el periodo inmediato anterior",
"Porcentaje de indicadores de la estrategia 1.5
que cumplen con la tendencia esperada entre el periodo
actual y el periodo inmediato anterior",
"Porcentaje de indicadores de la estrategia 1.6
que cumplen con la tendencia esperada entre el periodo
actual y el periodo inmediato anterior"
),
Valor = round(c(0.111,0.4111,0.25,0,0.2,432), digits = 2),
`Método de cálculo` = c("Número de indicadores que cumplen/Total de indicadores de la estrategia 1.1",
"Número de indicadores que cumplen/Total de indicadores de la estrategia 1.2",
"Número de indicadores que cumplen/Total de indicadores de la estrategia 1.3",
"Número de indicadores que cumplen/Total de indicadores de la estrategia 1.4",
"Número de indicadores que cumplen/Total de indicadores de la estrategia 1.5",
"Número de indicadores que cumplen/Total de indicadores de la estrategia 1.6"))
# Function for barchart
bar_chart <- function(label, width = "100%", height = "14px", fill = "#00bfc4", background = NULL) {
bar <- div(style = list(background = fill, width = width, height = height))
chart <- div(style = list(flexGrow = 1, marginLeft = "6px", background = background), bar)
div(style = list(display = "flex", alignItems = "center"), label, chart)
}
###table
reactable(
Objetivo_1,
bordered = TRUE,
searchable = TRUE,
language = reactableLang(
searchPlaceholder = "Busqueda",
noData = "Sin coincidencias",
pageInfo = "{rowStart} a {rowEnd} de {rows} entries",
pagePrevious = "\u276e",
pageNext = "\u276f",
# Accessible labels for assistive technologies such as screen readers.
# These are already set by default, but don't forget to update them when
# changing visible text.
pagePreviousLabel = "Página anterior",
pageNextLabel = "Siguiente página"
),
defaultSorted = "Valor",
columns = list(
Nombre.del.indicador = colDef(
name = "Nombre del indicador"
),
Método.de.cálculo = colDef(
name = "Método de cálculo"
),
Valor = colDef(
name = " Valor",
defaultSortOrder = "desc",
# Render the bar charts using a custom cell render function
cell = function(value) {
# Format as percentages with 1 decimal place
value <- paste0(format(value * 100, nsmall = 1), "%")
bar_chart(value, width = value, fill = "#822b2b", background = "#e1e1e1")
},
# And left-align the columns
align = "left"
)
)
)
By changing bar_chart slightly,
bar_chart <- function(label, width = "100%", height = "14px", fill = "#00bfc4", background = NULL) {
if (label == "0.0%"){
div('nd')
} else{
bar <- div(style = list(background = fill, width = width, height = height))
chart <- div(style = list(flexGrow = 1, marginLeft = "6px", background = background), bar)
div(style = list(display = "flex", alignItems = "center"), label, chart)
}
}
You may get nd instead of bar

Display graph with ggplot in Shiny app with a function

I'm doing right now a shiny web app, in order to plot some data that comes from csv files.
Here my code concerning the shiny app :
# install.packages("shiny")
library(shiny)
source("test.R")
# library(...) that I need
# User Interface
ui <- fluidPage(
titlePanel("Affichage de l'indice EPU"),
sidebarLayout(
sidebarPanel(
helpText("Choix des paramètres"),
selectInput("var",
label = "Choisir une variable à afficher",
choices = list("Global",
"France",
"Royaume-Uni"),
selected = "Percent White"),
dateRangeInput("dateRange",
label = "Intervalle de temps : ",
format = "mm/yyyy",
language="fr",
start = "2018-01-01",
end = Sys.Date(),
startview = "year",
separator = " - ")
),
mainPanel(plotOutput("p")
)
)
)
# Define server logic required to draw a histogram ----
server <- function(input, output) {
output$p <- renderPlot({
graph_epu()
})
}
shinyApp(ui = ui, server = server)
For the moment, I don't use input in User Interface function, I just want to plot the data.
My function, inside the file test.R, do some things in order to generate a graph.
Here my function :
graph_epu <- function(){
# On importe les données du csv dans les dataframes
df_lesechos <- read.csv(file = "data/df_lesechos.csv", sep=",")
df_latribune <- read.csv(file = "data/df_latribune.csv", sep=",")
# On supprime le jour pour le remplacer par 01
df_lesechos$Date <- substr(df_lesechos$Date,1,7)
df_latribune$Date <- substr(df_latribune$Date,1,7)
df_lesechos$Date <- paste(df_lesechos$Date,"-01",sep="")
df_latribune$Date <- paste(df_latribune$Date,"-01",sep="")
# Transforme la colonne Occurences au format numérique
#df_lesechos <- transform(df_lesechos, Occurences = as.numeric(Occurences))
#df_latribune <- transform(df_latribune, Occurences = as.numeric(Occurences))
df_lesechos$Occurences <- as.numeric(df_lesechos$Occurences)
df_latribune$Occurences <- as.numeric(df_latribune$Occurences)
# On convertit la colonne date au format Date
df_lesechos <- transform(df_lesechos, Date = as.Date(Date))
df_latribune <- transform(df_latribune, Date = as.Date(Date))
# On élimine les valeurs datant d'avant 2018
df_lesechos <- df_lesechos[!(df_lesechos$Date < "2018-01-01"),]
df_latribune <- df_latribune[!(df_latribune$Date < "2018-01-01"),]
# On groupe par mois et on fait la somme des occurences
df_lesechos <- df_lesechos %>% group_by(Date) %>% summarise(Occurences = sum(Occurences)) %>% arrange(desc(Date))
df_latribune <- df_latribune %>% group_by(Date) %>% summarise(Occurences = sum(Occurences)) %>% arrange(desc(Date))
# Calcul de la variance pour chaque journal
echos_var <- var(df_lesechos$Occurences)
tribune_var <- var(df_latribune$Occurences)
# Divisions des occurences par l'écart type, ce qui nous donne un écart type unitaire
df_lesechos$Occurences <- (df_lesechos$Occurences) / sqrt(echos_var)
df_latribune$Occurences <- (df_latribune$Occurences) / sqrt(tribune_var)
# La normalisation de chaque série mensuelles des différents journaux nous permets de les combiner
# Création du dataframe qui va faire la somme des deux dataframes
df_france <- bind_rows(df_lesechos,df_latribune)
df_france <- df_france %>% group_by(Date) %>% summarise(Occurences = sum(Occurences)) %>% arrange(desc(Date))
# On divise par 2 la série obtenue car on a 2 sources d'informations
df_france$Occurences <- df_france$Occurences / 2
# Calcul de la moyenne de la série
moyenne <- mean(df_france$Occurences)
# On ramène la série à une moyenne de 100 afin d'obtenir l'indicateur EPU de chaque mois
df_france$Occurences <- df_france$Occurences*(100/moyenne)
# Visualisation de la série à l'aide ggplot2
p <- df_france %>%
ggplot(aes(x=Date, y=Occurences, text = paste0("Date : ", format(Date, "%Y-%m"), "\n",
"EPU : ", round(Occurences)))) +
geom_area(fill="#5685D7", alpha=0.5, group=1) +
geom_line(color="#FF0000", size=0.2, group=1) +
ggtitle("FR Indice EPU") +
ylab("EPU") +
xlab("Années-Mois") +
geom_point(size=0.5) +
scale_x_date(breaks = df_france$Date, labels = date_format("%Y-%m")) +
theme(axis.text.x = element_text(angle = 90),
plot.title = element_text(size=14, face="italic", family="Avenir Next"),
axis.title.x = element_text(family="Avenir Next"),
axis.title.y = element_text(family="Avenir Next"))
p <- ggplotly(p, tooltip = "text")
p
}
The object p is the graph.
i really don't know how to proceed in order to display the graph. When I run the app, only the sidebar is display, and there is no graph. I have any errors in the consol...
If someone can help me, it would be really great.
Thanks a lot !!!
Reading in the csv files on the server side might help. Try this
server <- function(input, output) {
# On importe les données du csv dans les dataframes
df_lesechosi <- read.csv(file = "data/df_lesechos.csv", sep=",")
df_latribunei <- read.csv(file = "data/df_latribune.csv", sep=",")
mygraph <- reactive({
graph_epu(df_lesechos=df_lesechosi, df_latribune=df_latribunei)
})
output$p <- renderPlotly({
mygraph()
})
}
### Your function should be as follows, and no need to read in csv files within this function
graph_epu <- function(df_lesechos="", df_latribune=""){...

Loosing a Column Value when Shiny executes my function - R

I have already composed a function that runs on shiny, when i run the function locally goes ok, but when run on shiny, the output only shows one of the two columns of the DF.
Data Frame on Rstudio,
enter image description here
################################################################
library(shiny)
source("LlamadaFunction.R", local = TRUE)
# Define server logic required to draw a histogram
server <- function(input, output, session){
table_FF <- reactive({data.frame(ImpresionPliegos(n_copias =input$des_copias, costes_arranque=input$des_Costes_Arranque, ancho=input$des_ancho_formato, alto=input$des_alto_formato, porcentaje_tinta=100,
Destino=input$destiny, papel=input$DES_PAPEL, caras=input$des_Caras, color=input$DES_COLOR, plastificado=input$des_plastificado,
caras_plastificadas=input$des_Caras_plasti, hendido=input$des_hendido, plegado=input$des_plegado, esquinas=input$des_esquinas,
agujeros=input$des_agujeros, troquelado = input$des_troquelado, beneficio=input$des_beneficio, peso=input$des_peso, n_paquetes=input$des_paquetes))})
plots.dfs <- eventReactive(input$button, {return(list(table_FF()))})
output$table1 <- renderTable({ plots.dfs()[[1]] })
}
#
# This is the user-interface definition of a Shiny web application. You can
# run the application by clicking 'Run App' above.
#
# Find out more about building applications with Shiny here:
#
# http://shiny.rstudio.com/
#
library(DT)
library(shiny)
library("DBI")
library("RMySQL")
driver=dbDriver("MySQL");
conexion = dbConnect(driver,host="localhost",dbname="SQL_LOCAL_MAD20",user="root",pass="Guindalera00!!##?",port=3306);
##TABLAS PRINCIPALES
troquelado = dbSendQuery(conexion, "select * from SQL_LOCAL_MAD20.MIS_COSTES_TROQUELADO")
fetch
data_troquelado = fetch(troquelado, n=-1)
hendido = dbSendQuery(conexion, "select * from SQL_LOCAL_MAD20.MIS_COSTES_HENDIDO")
fetch
data_hendido = fetch(hendido, n=-1)
plastificado = dbSendQuery(conexion, "select * from SQL_LOCAL_MAD20.MIS_COSTES_PLASTIFICADO")
fetch
data_plastificado = fetch(plastificado, n=-1)
color = dbSendQuery(conexion, "select * from SQL_LOCAL_MAD20.MIS_COSTES_COLOR")
fetch
data_color = fetch(color, n=-1)
tinta = dbSendQuery(conexion, "select * from SQL_LOCAL_MAD20.MIS_COSTES_TINTA")
fetch
data_tinta = fetch(tinta, n=-1)
vinilo = dbSendQuery(conexion, "select * from SQL_LOCAL_MAD20.MIS_COSTES_VINILO")
fetch
data_vinilo = fetch(vinilo, n=-1)
papel = dbSendQuery(conexion, "select * from SQL_LOCAL_MAD20.MIS_COSTES_PAPEL")
fetch
data_papel = fetch(papel, n=-1)
envio = dbSendQuery(conexion, "select * from SQL_LOCAL_MAD20.MIS_COSTES_ENVIO")
fetch
data_envio = fetch(envio, n=-1)
# Define UI for application that draws a histogram
shinyUI(fluidPage(
# Application title
titlePanel("Quinteral PVP APP"),
numericInput("des_copias",
label = "Numero de copias minimo",
value = 1, max=10000000, step=100),
selectInput("DES_PAPEL",
label = "Escoja un tipo de Papel",
choices = data_papel$DES_PAPEL,
selected = "Estucado brillo 150"),
numericInput("des_Caras",
label = "Numero de Caras",
value = 1, max=2, step=1),
numericInput("des_Caras_plasti",
label = "Numero de Caras plastificadas",
value = 1, max=2, step=1),
numericInput("des_Costes_Arranque",
label = "Costes de Arranque",
value = 0, max=100000),
numericInput("des_ancho_formato",
label = "Formato de Ancho. MAX 32",
value = 10, max=32),
numericInput("des_alto_formato",
label = "Formato de Alto. MAX 45",
value = 10, max=45),
selectInput("DES_COLOR",
label = "Escoja el Color de Impresion",
choices = data_color$DES_COLOR,
selected = "Color Blanco y Negro 1"),
selectInput("des_plastificado",
label = "Escoja el tipo de plastificado",
choices = data_plastificado$DES_PLASTIFICADO,
selected = "NA"),
selectInput("des_hendido",
label = "Escoja el tipo de hendido, si aplica, ",
choices = c("HENDIDO","NA"),
selected = "NA"),
selectInput("des_plegado",
label = "Escoja el tipo de plegado, si aplica,",
choices = c("PLEGADO","NA"),
selected = "NA"),
selectInput("des_esquinas",
label = "Escoja el tipo de Esquinas, si aplica, ",
choices = c("ESQUINAS", "NA"),
selected = "NA"),
selectInput("des_agujeros",
label = "Escoja si conlleva agujeros, si aplica, ",
choices = c("AGUJEROS", "NA"),
selected = "NA"),
selectInput("des_troquelado",
label = "Escoja el tipo de troquelado",
choices = data_troquelado$DES_TROQUELADO,
selected = "Troquelado 10"),
selectInput("destiny",
label = "Seleccione el Destino del Envio: (P -> PENINSULA, B -> BALEARES, C -> CANARIAS, E -> EUROPA",
choices = data_envio$COD_DESTINO),
numericInput("des_peso",
label = "Peso Final Conjunto",
value = 1, max=50),
numericInput("des_paquetes",
label = "Seleccione en cuantos paquetes desea que vaya el envio",
value = 1, max=20),
numericInput("des_beneficio",
label = "Seleccione que % de Beneficio desea obtener.",
value = 1, max=1000),
sidebarPanel(
actionButton("button", label="Clikea sobre el boton")
),
mainPanel(
tableOutput("table1")
)
))
ImpresionPliegos <- function(n_copias =100, costes_arranque=1000, ancho=10, alto=10, porcentaje_tinta=100,
Destino='P', papel='Estucado brillo 150', caras=1, color='Color Completo 1', plastificado='Plastificado mate por cara',
caras_plastificadas=1, hendido='HENDIDO', plegado='PLEGADO', esquinas='ESQUINAS',
agujeros='AGUJEROS', troquelado = 'Troquelado 10', beneficio=0.33, peso=10, n_paquetes=2) {
#se calcula el modelo para el numero de copias originles, mas otros posibles escenarios.
copias_vector = c(n_copias, n_copias*2.5, n_copias*5, n_copias*10)
#se calcula el ancho real y el largo real, por que hay que respetar los margenes de impresion y los cortes
ancho_real = ancho + 0.05
alto_real = alto + 0.05
#ya podemos sabes cuantas uds caben por pliego.
uds_pliego = round(32/ancho_real, 0) * round(45/alto_real, 0)
#calculamos los costes unitarios
coste_papel_unit_df=subset(data_papel, DES_PAPEL == papel)
coste_papel_unit = coste_papel_unit_df$COSTE_UNIT
coste_color_unit_df=subset(data_color, DES_COLOR == color)
coste_color_unit = coste_color_unit_df$COSTE_UNIT
coste_plastificado_unit_df=subset(data_plastificado, DES_PLASTIFICADO == plastificado)
coste_plastificado_unit = coste_plastificado_unit_df$COSTE_UNIT
coste_hendido_unit_df=subset(data_hendido, COD_HENDIDO == hendido)
coste_hendido_unit = coste_hendido_unit_df$COSTE_UNIT
coste_plegado_unit_df=subset(data_hendido, COD_HENDIDO == plegado)
coste_plegado_unit = coste_plegado_unit_df$COSTE_UNIT
coste_esquinas_unit_df=subset(data_hendido, COD_HENDIDO == esquinas)
coste_esquinas_unit = coste_esquinas_unit_df$COSTE_UNIT
coste_agujeros_unit_df=subset(data_hendido, COD_HENDIDO == agujeros)
coste_agujeros_unit = coste_agujeros_unit_df$COSTE_UNIT
coste_troquelado_unit_df=subset(data_troquelado, DES_TROQUELADO == troquelado)
coste_troquelado_unit = coste_troquelado_unit_df$COSTE_UNIT
total_pliegos= trunc(copias_vector/uds_pliego) + 4 #siempre se necesitan 3 pliegos de margen + 1 de redondeo hacia arriba
#Coste de Papel
Coste_Papel = coste_papel_unit*total_pliegos
Coste_impresion = coste_color_unit*total_pliegos*caras
Coste_plastificado = coste_plastificado_unit*total_pliegos*caras_plastificadas
Coste_troquelado=coste_troquelado_unit*total_pliegos
millares = round(total_pliegos/1000, 0)+1
Coste_hendido_full_unit=coste_hendido_unit+coste_plegado_unit+coste_esquinas_unit+coste_agujeros_unit
coste_hendido_full = Coste_hendido_full_unit*millares
Coste_final_unit=Coste_Papel+Coste_impresion+Coste_plastificado+Coste_troquelado+coste_hendido_full
#Costes de envio
paks = n_paquetes
kg_finales = peso
peso_medio=round(kg_finales/paks, 0)
coste_unit_kg_envio = subset(data_envio, COD_DESTINO==Destino & NUM_PESO == peso_medio)
peso_x=coste_unit_kg_envio$NUM_PESO
kgs_adicionales <- ifelse(peso_medio - peso_x <=0, 0, round(peso_medio - peso_x, 0))
coste_unit_envio_final<-coste_unit_kg_envio$COSTE_ENVIO
coste_adic_final<-coste_unit_kg_envio$COSTE_ADICIONAL_KG
costes_envio=coste_unit_envio_final*peso_x + kgs_adicionales*coste_adic_final
###
bf<- beneficio
CF <- costes_arranque+costes_envio
pvp=(Coste_final_unit+CF) * (1+bf)
table33 <- as.data.frame(cbind(copias_vector, pvp), c("COPIAS","PVP"))
return(table33)
}

Separate factor into columns R

I am trying to separate (tidyr) line_text into separate words so it's one word per column.
Data:
structure(list(ID = c(140L, 233L, 233L),
pdf_name = structure(c(1L,
2L, 2L), .
Label = c("GBD2016_2_1255_Venezuela_MoH_Epi_2012_9.pdf",
"GBD2016_2_1351_Venezuela_MoH_Epi_2014_44.pdf"),
class = "factor"),
keyword = c("SEGÚN GRUPOS", "SEGÚN GRUPOS", "SEGÚN GRUPOS"
), line_text = list("2000 Gráfico 2 . CASOS DE MALARIA SEGÚN GRUPOS DE EDAD Y SEXO, EPIDEMIOLÓGICA 9 Año 2012",
"GRÁFICO 2. CASOS DE MALARIA SEGÚN GRUPOS DE EDAD Y SEXO, HASTA",
"GRÁFICO 2. CASOS DE SEGÚN GRUPOS"),
.Names = c("ID", "pdf_name", "keyword",
"page_num", "line_num", "line_text", "token_text"), row.names = c(NA,
-3L), class = "data.frame")
Coded used:
numcols<- make.unique(c(rep("word",10, sep = " ")) )
df<- reportdiagn%>%
(separate(reportdiagn$line_text,
into = numcols,
sep = ("")))
I get the following error and can't work out how to fix it.
`Error in UseMethod("separate_") :
no applicable method for 'separate_' applied to an object of class "factor
The data you pasted isn't quite right. Might be good to try that again - but I have tried to reproduce your data anyway. It might not be exactly the same. I have set linetext to be a character string - but I think the code below works in either character or factor.
In select(), you don't need to reference the data frame - the %>% already does that, you just need the name of the variable without quotes. Also, your sep needs to be a space or \\b for a word boundary.
ID <- c(140, 233, 233)
pdf_name <- factor(c(1, 2, 2),
labels = c(
"GBD2016_2_1255_Venezuela_MoH_Epi_2012_9.pdf",
"GBD2016_2_1351_Venezuela_MoH_Epi_2014_44.pdf")
)
keyword <- c("SEGÚN GRUPOS", "SEGÚN GRUPOS", "SEGÚN GRUPOS")
line_text <- c("2000 Gráfico 2 . CASOS DE MALARIA SEGÚN GRUPOS DE EDAD Y SEXO, EPIDEMIOLÓGICA 9 Año 2012",
"GRÁFICO 2. CASOS DE MALARIA SEGÚN GRUPOS DE EDAD Y SEXO, HASTA",
"GRÁFICO 2. CASOS DE SEGÚN GRUPOS.")
reportdiagn <- data.frame(ID, pdf_name, keyword, line_text)
numcols<- make.unique(c(rep("word",10 )) )
df <- reportdiagn %>%
separate(line_text,
into = numcols,
sep = " ")
This produces some NA values where there's less than 10 words and truncates when there's more. I assume you're expecting that.

how to debug R scripts

I´ve made a little simulator to teach the basics of population dynamics under stochasticity. This is a simple viz for the Ricker equation. It works in linux, however, I get a criptic error while running it under other environment (macos, win).
So, I wonder what my best options are to debug this error:
<simpleError in is.list(x): object of type 'closure' is not subsettable>
here is the code. I suspect on the plotly library in R... any hint?
# Ejercicio para ensenar curvas de crecimiento poblacional
# _author_ = horacio.samaniego#gmail.com
# _date_ = August 2018
# Check whether required packages are installed
list.of.packages <- c("manipulateWidget", "plotly")
new.packages <- list.of.packages[!(list.of.packages %in% installed.packages()[,"Package"])]
if(length(new.packages)) install.packages(new.packages)
# librerias requeridas
library(manipulateWidget)
library(plotly)
# Simulador
crecLogistico <- function(t=80,r=1,n0=10,K=60,d=0){
# Simulacion de crecimiento poblacional con tasa de crecimiento (r) variable
# que simula variabilidad (estocasticidad ambiental)
# t, numero de generaciones a simular
# r, tasa intrinsica de crecimiento
# n0, abundancia inicial
# K, capacidad de carga
# d, estocasticidad
N <- matrix(n0,ncol=t,nrow=1) # vector con tamano poblacional (abundancia) inicial
R <- matrix(NA,ncol=t,nrow=1) # vector con tasas de crecimiento
for(i in 1:t) {
if(d>0) R[i] <- rnorm(1,mean=r,sd=d) else R[i] <- r
# N[i+1] <- N[i]+N[i]*R[i]*(1-N[i]/K) # Logistica
N[i+1] <- N[i]*exp(R[i]*(1 - N[i]/K)) # Ricker
}
res <- matrix(c(1:t,N[-(t+1)],R),ncol=3)
res <- as.data.frame(res)
names(res) <- c("t","Abundancia","r")
return(res)
}
## Plot de Crecimiento Logistico
if ( require(plotly) ) {
manipulateWidget({
# Modela abundancias
res = crecLogistico(n0=n0,t=t,r=r,K=K,d=d)
# Colecta informacion para construir mapa logistico
mapa = data.frame("N_1"=res$Abundancia[-t],"N_0"=res$Abundancia[-1])
combineWidgets( # crea ventanas donde plotear (proporcion 3:1). Una grande a la izq y otra con 2 lineas a la dcha (1:1)
ncol = 2,colsize=c(3,1),
# Evolucion temporal de poblacion
p = plot_ly(res[rango[1]:rango[2],],x=~t,y=~Abundancia,type="scatter",
mode="lines+markers",line=~r,color=~r), # %>%
# agrega linea para remarcar abundancia = 0
add_segments(p, x = rango[1], xend = rango[2], y = 0, yend = 0,mode="lines") %>%
# muestra escocasticidad a cada tiempo segun color
colorbar(title="Tasa de Crecimiento") %>%
layout(title="Crecimiento Logistico",showlegend = FALSE,yaxis=list(zerolinecolor=toRGB("red"))),
combineWidgets(
ncol = 1,
# histograma de estocasticidad a lo largo de todo el tiempo
plot_ly(res,x=~r,type="histogram") %>%
layout(title="Tasa de Crecimiento"),
# mapa logistico, muestra estados estacionarios en primer orden, de t-a a t
plot_ly(mapa,x=~N_1,y=~N_0,type="scatter",mode="markers") %>%
add_segments(x=0,xend=max(res$Abundancia),y=0,yend=max(res$Abundancia)) %>%
layout(title="Mapa Logistico", xaxis = list(title = "abundancia (t)"),
yaxis = list(title="abundancia (t-1)"))
)
)
},
n0 = mwNumeric(100, min = 2, step = 1 , label = "Poblacion Inicial"),
t = mwNumeric(100, min = 2, step = 1 , label = "Generaciones (t)"),
r = mwNumeric(0.9, min = -4, step = 0.05 , label = "Tasa de Crecimiento (r)"),
K = mwNumeric(60, min = 5, step = 2, label = "Capacidad de Carga"),
d = mwNumeric(0.05, min = 0, step = 0.05 ,label = "Estocasticidad"),
rango = mwSlider(0, t, c(1, t),label="Generaciones a Visualizar")
)
}
will report... thanks a bunch!!
Ok, I've got the issue... the problem is that plotly in R (or rstudio) for linux is not too picky about the 'line' flag in plot_ly, which macos strictly enforces.
I unfortunately have no training in debugging code and would not be able diagnose this using the standard tools mentioned here (will learn though!)
recasting the line to this:
plot_ly(res[rango[1]:rango[2],],x=~t,y=~Abundancia,type="scatter", mode="lines+markers",color=~r) %>%
did all the trick.
Thanks,
I'll copy my equation explorer here just in case:
# Ejercicio para ensenar curvas de crecimiento poblacional
# _author_ = horacio.samaniego#gmail.com
# _date_ = August 2018
# Check whether required packages are installed
list.of.packages <- c("manipulateWidget", "plotly")
new.packages <- list.of.packages[!(list.of.packages %in% installed.packages()[,"Package"])]
if(length(new.packages)) install.packages(new.packages)
# librerias requeridas
library(manipulateWidget)
library(plotly)
# Simulador
crecLogistico <- function(t=80,r=1,n0=10,K=60,d=0){
# Simulacion de crecimiento poblacional con tasa de crecimiento (r) variable
# que simula variabilidad (estocasticidad ambiental)
# t, numero de generaciones a simular
# r, tasa intrinsica de crecimiento
# n0, abundancia inicial
# K, capacidad de carga
# d, estocasticidad
N <- matrix(n0,ncol=t,nrow=1) # vector con tamano poblaciona (abundancia) inicial
R <- matrix(NA,ncol=t,nrow=1) # vector con tasas de crecimiento
for(i in 1:t) {
if(d>0) R[i] <- rnorm(1,mean=r,sd=d) else R[i] <- r # adds stochasticity
# N[i+1] <- N[i]+N[i]*R[i]*(1-N[i]/K) # Logistica
N[i+1] <- N[i]*exp(R[i]*(1 - N[i]/K)) # Ricker
}
res <- matrix(c(1:t,N[-(t+1)],R),ncol=3)
res <- as.data.frame(res)
names(res) <- c("t","Abundancia","r")
return(res)
}
## Plot de Crecimiento Logistico
if ( require(plotly) ) {
manipulateWidget({
# Modela abundancias
res = crecLogistico(n0=n0,t=t,r=r,K=K,d=d)
# Colecta informacion para construir mapa logistico
mapa = data.frame("N_1"=res$Abundancia[-t],"N_0"=res$Abundancia[-1])
combineWidgets( # crea ventanas donde plotear (proporcion 3:1). Una grande a la izq y otra con 2 lineas a la dcha (1:1)
ncol = 2,colsize=c(3,1),
# Evolucion temporal de poblacion
plot_ly(res[rango[1]:rango[2],],x=~t,y=~Abundancia,type="scatter", mode="lines+markers",color=~r) %>%
# # muestra escocasticidad a cada tiempo segun color
colorbar(title="Tasa de Crecimiento") %>%
layout(title="Crecimiento Logistico",showlegend = FALSE,yaxis=list(zerolinecolor=toRGB("red"))),
combineWidgets(
ncol = 1,
# histograma de estocasticidad a lo largo de todo el tiempo
plot_ly(res,x=~r,type="histogram") %>%
layout(title="Tasa de Crecimiento"),
# mapa logistico, muestra estados estacionarios en primer orden, de t-a a t
plot_ly(mapa,x=~N_1,y=~N_0,type="scatter",mode="markers") %>%
add_segments(x=0,xend=max(res[[2]]),y=0,yend=max(res[[2]])) %>%
layout(title="Mapa Logistico", xaxis = list(title = "abundancia (t)"),
yaxis = list(title="abundancia (t-1)"),showlegend = FALSE)
)
)
},
n0 = mwNumeric(100, min = 2, step = 1 , label = "Poblacion Inicial"),
t = mwNumeric(100, min = 2, step = 1 , label = "Generaciones (t)"),
r = mwNumeric(0.9, min = -4, step = 0.05 , label = "Tasa de Crecimiento (r)"),
K = mwNumeric(60, min = 5, step = 2, label = "Capacidad de Carga"),
d = mwNumeric(0.05, min = 0, step = 0.05 ,label = "Estocasticidad"),
rango = mwSlider(0, t, c(1, t),label="Generaciones a Visualizar")
)
}

Resources